FoXy XML tag class.
!< FoXy XML tag class. module foxy_xml_tag !< FoXy XML tag class. use penf use stringifor implicit none private public :: xml_tag type :: xml_tag !< XML tag class. !< !< A valid XML tag must have the following syntax for a tag without a content (with only attributes): !<```xml !< <Tag_Name att#1_Name="att#1_val" att#2_Name="att#2_val"... att#Nt_Name="att#Nt_val"/> !<``` !< while a tag with a content must have the following syntax: !<```xml !< <Tag_Name att#1_Name="att#1_val" att#2_Name="att#2_val"... att#Nt_Name="att#Nt_val">Tag_Content</Tag_Name> !<``` !< !< It is worth noting that the syntax is case sensitive and that the attributes are optional. Each attribute name must be !< followed by '="' without any additional white spaces and its value must be termined by '"'. Each attribute is separated !< by one or more white spaces. private type(string) :: tag_name !< Tag name. type(string) :: tag_content !< Tag content. integer(I4P) :: pos(3)=[0_I4P,0_I4P,0_I4P] !< Characters position (in source) indexes (start, content, end). type(string), allocatable :: attribute(:,:) !< Attributes names/values pairs, [1:2, 1:]. integer(I4P) :: attributes_number=0_I4P !< Number of defined attributes. integer(I4P) :: indent=0_I4P !< Number of indent-white-spaces. logical :: is_self_closing=.false. !< Self closing tag flag. integer(I4P) :: level=0_I4P !< Tag hierarchy level. integer(I4P) :: id=0_I4P !< Uniq tag ID. integer(I4P) :: parent_id=0_I4P !< Uniq ID of parent tag. integer(I4P), public :: children_number=0_I4P !< Number of children tags. integer(I4P), public, allocatable :: child_id(:) !< Uniq ID of children tags. contains ! public methods generic :: add_attributes => & add_single_attribute, & add_multiple_attributes, & add_stream_attributes !< Add attributes name/value pairs. procedure, pass(self) :: add_child_id !< Add child ID to children IDs list. procedure, pass(self) :: attributes !< Return attributes name/value pairs as string. generic :: delete_attributes => & delete_single_attribute, & delete_multiple_attributes !< Delete attributes name/value pairs. procedure, pass(self) :: delete_content !< Delete tag conent. procedure, pass(self) :: end_tag !< Return `</tag_name>` end tag. procedure, pass(self) :: free !< Free (reset) tag. procedure, pass(self) :: get_content !< Return tag content. procedure, pass(self) :: is_attribute_present !< Return .true. it the queried attribute name is defined. procedure, pass(self) :: is_parsed !< Check is tag is correctly parsed, i.e. its *tag_name* is allocated. procedure, pass(self) :: name !< Return tag name. procedure, pass(self) :: parse !< Parse the tag contained into a source string. procedure, pass(self) :: parse_tag_name !< Parse the tag name contained into a string. procedure, pass(self) :: self_closing_tag !< Return `<tag_name.../>` self closing tag. procedure, pass(self) :: set !< Set tag data. procedure, pass(self) :: start_tag !< Return `<tag_name...>` start tag. procedure, pass(self) :: stringify !< Convert the whole tag into a string. procedure, pass(self) :: write => write_tag !< Write tag to unit file. generic :: assignment(=) => assign_tag !< Assignment operator overloading. ! private methods procedure, pass(self), private :: add_single_attribute !< Add one attribute name/value pair. procedure, pass(self), private :: add_multiple_attributes !< Add list of attributes name/value pairs. procedure, pass(self), private :: add_stream_attributes !< Add list of attributes name/value pairs passed as stream. procedure, pass(self), private :: alloc_attributes !< Allocate (prepare for filling) dynamic memory of attributes. procedure, pass(self), private :: delete_single_attribute !< Delete one attribute name/value pair. procedure, pass(self), private :: delete_multiple_attributes !< Delete list of attributes name/value pairs. procedure, pass(self), private :: get !< Get the tag value and attributes from source. procedure, pass(self), private :: get_value !< Get the tag value from source after tag_name has been set. procedure, pass(self), private :: get_attributes !< Get the attributes values from source. procedure, pass(self), private :: parse_attributes_names !< Parse the tag attributes names contained into a string. procedure, pass(self), private :: search !< Search tag named *tag_name* into a string. ! operators procedure, pass(lhs), private :: assign_tag !< Assignment between two tags. final :: finalize !< Free dynamic memory when finalizing. endtype xml_tag interface xml_tag !< Overload *xml_tag* with creator procedures. module procedure create_tag_flat, create_tag_nested endinterface contains ! creator procedures overloading *xml_tag* name pure function create_tag_flat(name, attribute, attributes, attributes_stream, sanitize_attributes_value, pos, content, & indent, is_content_indented, is_self_closing, id, level, parent_id, attributes_stream_alloc, & content_alloc) result(tag) !< Return an instance of xml tag. character(*), intent(in) :: name !< Tag name. character(*), intent(in), optional :: attribute(1:) !< Attribute name/value pair [1:2]. character(*), intent(in), optional :: attributes(1:,1:) !< Attributes list of name/value pairs [1:2,1:]. character(*), intent(in), optional :: attributes_stream !< Attributes list as single stream. logical, intent(in), optional :: sanitize_attributes_value !< Sanitize attributes value. integer(I4P), intent(in), optional :: pos(1:) !< Characters position (in source) indexes. character(*), intent(in), optional :: content !< Tag value. integer(I4P), intent(in), optional :: indent !< Number of indent-white-spaces. logical, intent(in), optional :: is_content_indented !< Activate content indentation. logical, intent(in), optional :: is_self_closing !< The tag is self closing. integer(I4P), intent(in), optional :: id !< Uniq ID. integer(I4P), intent(in), optional :: level !< Tag hierarchy level. integer(I4P), intent(in), optional :: parent_id !< Parent uniq ID. character(:), allocatable, intent(in), optional :: attributes_stream_alloc !< Attributes list stream, allocatable input. character(:), allocatable, intent(in), optional :: content_alloc !< Tag value, allocatable input. type(xml_tag) :: tag !< XML tag. call tag%set(name=name, & attribute=attribute, & attributes=attributes, & attributes_stream=attributes_stream, & sanitize_attributes_value=sanitize_attributes_value, & content=content, & pos=pos, & indent=indent, & is_content_indented=is_content_indented, & is_self_closing=is_self_closing, & id=id, & level=level, & parent_id=parent_id, & attributes_stream_alloc=attributes_stream_alloc, & content_alloc=content_alloc) endfunction create_tag_flat pure function create_tag_nested(name, content, attribute, attributes, attributes_stream, sanitize_attributes_value, pos, indent,& is_content_indented, id, level, parent_id, attributes_stream_alloc, content_alloc) result(tag) !< Return an instance of xml tag with value being a nested tag. character(*), intent(in) :: name !< Tag name. type(xml_tag), intent(in) :: content !< Tag value as nested tag.. character(*), intent(in), optional :: attribute(1:) !< Attribute name/value pair [1:2]. character(*), intent(in), optional :: attributes(1:,1:) !< Attributes list of name/value pairs [1:2,1:]. character(*), intent(in), optional :: attributes_stream !< Attributes list as single stream. logical, intent(in), optional :: sanitize_attributes_value !< Sanitize attributes value. integer(I4P), intent(in), optional :: pos(1:) !< Characters position (in source) indexes. integer(I4P), intent(in), optional :: indent !< Number of indent-white-spaces. logical, intent(in), optional :: is_content_indented !< Activate value indentation. integer(I4P), intent(in), optional :: id !< Uniq ID. integer(I4P), intent(in), optional :: level !< Tag hierarchy level. integer(I4P), intent(in), optional :: parent_id !< Parent uniq ID. character(:), allocatable, intent(in), optional :: attributes_stream_alloc !< Attributes list stream, allocatable input. character(:), allocatable, intent(in), optional :: content_alloc !< Tag value, allocatable input. type(xml_tag) :: tag !< XML tag. call tag%set(name=name, & attribute=attribute, & attributes=attributes, & content=content%stringify(), & sanitize_attributes_value=sanitize_attributes_value, & attributes_stream=attributes_stream, & pos=pos, & indent=indent, & is_content_indented=is_content_indented, & id=id, & level=level, & parent_id=parent_id, & attributes_stream_alloc=attributes_stream_alloc, & content_alloc=content_alloc) endfunction create_tag_nested ! public methods pure subroutine add_child_id(self, child_id) !< Add child ID to children IDs list. class(xml_tag), intent(inout) :: self !< XML tag. integer(I4P), intent(in) :: child_id !< Child ID. if (allocated(self%child_id)) then self%child_id = [self%child_id, child_id] else self%child_id = [child_id] endif self%children_number = size(self%child_id) endsubroutine add_child_id pure function attributes(self) result(att_) !< Return attributes name/value pairs as string. class(xml_tag), intent(in) :: self !< XML tag. character(len=:), allocatable :: att_ !< The attributes string. integer(I4P) :: a !< Counter. if (self%attributes_number>0) then att_ = '' do a=1, self%attributes_number att_ = att_//' '//self%attribute(1, a)//'="'//self%attribute(2, a)//'"' enddo att_ = trim(adjustl(att_)) endif endfunction attributes pure function end_tag(self, is_indented) result(tag_) !< Return `</tag_name>` end tag. class(xml_tag), intent(in) :: self !< XML tag. logical, intent(in), optional :: is_indented !< Activate content indentation. character(len=:), allocatable :: tag_ !< The end tag string. tag_ = '</'//self%tag_name//'>' if (present(is_indented)) then if (is_indented) tag_ = repeat(' ', self%indent)//tag_ endif endfunction end_tag elemental subroutine free(self) !< Free (reset) tag. class(xml_tag), intent(inout) :: self !< XML tag. integer(I4P) :: i,j !< Counter. call self%tag_name%free call self%tag_content%free self%pos = 0_I4P if (allocated(self%attribute)) then do j=1, size(self%attribute, dim=2) do i=1, size(self%attribute, dim=1) call self%attribute(i,j)%free enddo enddo deallocate(self%attribute) self%attributes_number = 0_I4P endif self%indent = 0_I4P self%is_self_closing = .false. self%level = 0_I4P self%id = 0_I4P self%parent_id = 0_I4P self%children_number = 0_I4P if (allocated(self%child_ID)) deallocate(self%child_ID) endsubroutine free pure subroutine get_content(self, name, content) !< Return tag content of self (or its nested tags) if named *name*. !< !< @note If there is no value, the *content* string is returned deallocated. class(xml_tag), intent(in) :: self !< XML tag. character(*), intent(in) :: name !< Searched tag name. character(len=:), allocatable, intent(out) :: content !< Tag content. type(xml_tag) :: tag !< Dummy XML tag. if (allocated(content)) deallocate(content) if (self%tag_name%is_allocated()) then if (self%tag_name==name) then if (self%tag_content%is_allocated()) content = self%tag_content%chars() else if (self%tag_content%is_allocated()) then call tag%search(tag_name=name, source=self%tag_content%chars()) if (tag%tag_content%is_allocated()) content = tag%tag_content%chars() endif endif endif endsubroutine get_content pure function is_attribute_present(self, name) result(is_present) !< Return .true. it the queried attribute name is defined, .false. otherwise. class(xml_tag), intent(in) :: self !< XML tag. character(*), intent(in) :: name !< Attribute name. logical :: is_present !< Inquire result. integer(I4P) :: a !< Counter. is_present = .false. if (self%attributes_number>0) then do a=1, self%attributes_number if (self%attribute(1, a)==name) then is_present = .true. exit endif enddo endif endfunction is_attribute_present elemental function is_parsed(self) !< Check is tag is correctly parsed, i.e. its *tag_name* is allocated. class(xml_tag), intent(in) :: self !< XML tag. logical :: is_parsed !< Result of check. is_parsed = self%tag_name%is_allocated() endfunction is_parsed pure function name(self) !< Return tag name. class(xml_tag), intent(in) :: self !< XML tag. character(len=:), allocatable :: name !< XML tag name. name = self%tag_name%chars() endfunction name elemental subroutine parse(self, source, tstart, tend) !< Parse the tag contained into a source string. !< !< It is assumed that the first tag contained into the source string is parsed, the others eventually present are omitted. !< Valid syntax are: !< + `<tag_name att1="att1 val" att2="att2 val"...>...</tag_name>` !< + `<tag_name att1="att1 val" att2="att2 val".../>` !< @note Inside the attributes value the symbols `<` and `>` are not allowed. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: source !< String containing the input. integer(I4P), optional, intent(out) :: tstart !< Starting index of tag inside the string. integer(I4P), optional, intent(out) :: tend !< Ending index of tag inside the string. integer(I4P) :: tstartd !< Starting index of tag inside the string. integer(I4P) :: tendd !< Ending index of tag inside the string. tstartd = 0 tendd = 0 call self%parse_tag_name(source=source, tstart=tstartd, tend=tendd) if (self%tag_name%is_allocated()) then if (index(string=source(tstartd:tendd), substring='=')>0) call self%parse_attributes_names(source=source(tstartd:tendd)) if (index(string=source, substring='</'//self%tag_name//'>')>0) & tendd = index(string=source, substring='</'//self%tag_name//'>') + len('</'//self%tag_name//'>') - 1 call self%get(source=source(tstartd:tendd)) endif if (present(tstart)) tstart = tstartd if (present(tend )) tend = tendd endsubroutine parse elemental subroutine parse_tag_name(self, source, tstart, tend) !< Parse the tag name contained into a string. !< !< It is assumed that the first tag contained into the source is parsed, the others eventually present are omitted. !< Valid syntax are: !< + `<tag_name att1="att1 val" att2="att2 val"...>...</tag_name>` !< + `<tag_name att1="att1 val" att2="att2 val".../>` !< @note Inside the attributes value the symbols `<` and `>` are not allowed. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: source !< String containing the input. integer(I4P), optional, intent(out) :: tstart !< Starting index of tag inside the source. integer(I4P), optional, intent(out) :: tend !< Ending index of tag inside the source. integer(I4P) :: tstartd !< Starting index of tag inside the source. integer(I4P) :: tendd !< Ending index of tag inside the source. character(len=1) :: c1 !< Dummy string for parsing file. character(len=:), allocatable :: c2 !< Dummy string for parsing file. integer(I4P) :: c !< Counter. integer(I4P) :: s !< Counter. call self%tag_name%free tstartd = 0 tendd = 0 c = 1 Tag_Search: do while(c<=len(source)) c1 = source(c:c) if (c1=='<'.and.source(c+1:c+1)/='/') then tstartd = c c2 = c1 Tag_Name: do while(c<len(source)) c = c + 1 ; c1 = source(c:c) c2 = c2//c1 if (c1=='>') then tendd = c exit Tag_Name endif enddo Tag_Name s = index(string=c2, substring=' ') if (s>0) then ! there are attributes self%tag_name = c2(2:s-1) else if (index(string=c2, substring='/>')>0) then ! self closing tag self%tag_name = c2(2:len(c2)-2) else self%tag_name = c2(2:len(c2)-1) endif endif exit Tag_Search endif c = c + 1 enddo Tag_Search if (present(tstart)) tstart = tstartd if (present(tend )) tend = tendd endsubroutine parse_tag_name pure subroutine set(self, name, attribute, attributes, attributes_stream, sanitize_attributes_value, content, & pos, indent, is_content_indented, is_self_closing, id, level, parent_id, & attributes_stream_alloc, content_alloc) !< Set tag data. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in), optional :: name !< Tag name. character(*), intent(in), optional :: attribute(1:) !< Attribute name/value pair [1:2]. character(*), intent(in), optional :: attributes(1:,1:) !< Attributes list of name/value pairs [1:2,1:]. character(*), intent(in), optional :: attributes_stream !< Attributes list of name/value pairs as stream. logical, intent(in), optional :: sanitize_attributes_value !< Sanitize attributes value. character(*), intent(in), optional :: content !< Tag value. integer(I4P), intent(in), optional :: pos(1:) !< Characters position (in source) indexes. integer(I4P), intent(in), optional :: indent !< Number of indent-white-spaces. logical, intent(in), optional :: is_content_indented !< Activate value indentation. logical, intent(in), optional :: is_self_closing !< The tag is self closing. integer(I4P), intent(in), optional :: id !< Uniq ID. integer(I4P), intent(in), optional :: level !< Tag hierarchy level. integer(I4P), intent(in), optional :: parent_id !< Parent uniq ID. character(:), allocatable, intent(in), optional :: attributes_stream_alloc !< Attributes list stream, allocatable input. character(:), allocatable, intent(in), optional :: content_alloc !< Tag value, allocatable input. logical :: is_content_indented_ !< Activate value indentation. is_content_indented_ = .false. ; if (present(is_content_indented)) is_content_indented_ = is_content_indented if (present(name)) self%tag_name = name if (present(attribute)) call self%add_single_attribute(attribute=attribute, sanitize_value=sanitize_attributes_value) if (present(attributes)) call self%add_multiple_attributes(attributes=attributes, sanitize_values=sanitize_attributes_value) if (present(attributes_stream)) call self%add_stream_attributes(attributes_stream=attributes_stream, & sanitize_values=sanitize_attributes_value) if (present(pos)) self%pos = pos if (present(indent)) self%indent = indent if (present(content)) then if (is_content_indented_) then self%tag_content = new_line('a')//repeat(' ', self%indent+2)//content//new_line('a') else self%tag_content = content endif endif if (present(is_self_closing)) self%is_self_closing = is_self_closing if (present(id)) self%id = id if (present(level)) self%level = level if (present(parent_id)) self%parent_id = parent_id if (present(attributes_stream_alloc)) then if (allocated(attributes_stream_alloc)) call self%add_stream_attributes(attributes_stream=attributes_stream_alloc, & sanitize_values=sanitize_attributes_value) endif if (present(content_alloc)) then if (allocated(content_alloc)) then if (is_content_indented_) then self%tag_content = new_line('a')//repeat(' ', self%indent+2)//content_alloc//new_line('a') else self%tag_content = content_alloc endif endif endif endsubroutine set pure function self_closing_tag(self, is_indented) result(tag_) !< Return `<tag_name.../>` self closing tag. class(xml_tag), intent(in) :: self !< XML tag. logical, intent(in), optional :: is_indented !< Flag to check if tag is indented. character(len=:), allocatable :: tag_ !< The self closing tag string. tag_ = '<'//self%tag_name if (self%attributes_number>0) tag_ = tag_//' '//self%attributes() tag_ = tag_//'/>' if (present(is_indented)) then if (is_indented) tag_ = repeat(' ', self%indent)//tag_ endif endfunction self_closing_tag pure function start_tag(self, is_indented) result(tag_) !< Return `<tag_name...>` start tag. class(xml_tag), intent(in) :: self !< XML tag. logical, intent(in), optional :: is_indented !< Flag to check if tag is indented. character(len=:), allocatable :: tag_ !< The start tag string. tag_ = '<'//self%tag_name if (self%attributes_number>0) tag_ = tag_//' '//self%attributes() tag_ = tag_//'>' if (present(is_indented)) then if (is_indented) tag_ = repeat(' ', self%indent)//tag_ endif endfunction start_tag pure function stringify(self, is_indented, is_content_indented, only_start, only_content, only_end, linearize) result(stringed) !< Convert the whole tag into a string. class(xml_tag), intent(in) :: self !< XML tag. logical, intent(in), optional :: is_indented !< Activate content indentation. logical, intent(in), optional :: is_content_indented !< Activate content indentation. logical, intent(in), optional :: only_start !< Write only start tag. logical, intent(in), optional :: only_content !< Write only content. logical, intent(in), optional :: only_end !< Write only end tag. logical, intent(in), optional :: linearize !< Return a "linearized" string of tags without the XML hieararchy. logical :: linearize_ !< Linearize sentinel, local var. character(len=:), allocatable :: stringed !< Output string containing the whole tag. logical :: is_content_indented_ !< Activate content indentation. logical :: only_start_ !< Write only start tag. logical :: only_content_ !< Write only content. logical :: only_end_ !< Write only end tag. linearize_ = .false. ; if (present(linearize)) linearize_ = linearize if (linearize_) then stringed = '' stringed = stringed//'name: "'//self%tag_name //'"'//new_line('a') if (self%attributes_number>0) stringed = stringed//'attributes: "'//self%attributes() //'"'//new_line('a') stringed = stringed//'char pos indexes:"'//trim(str(self%pos)) //'"'//new_line('a') stringed = stringed//'content: "'//self%tag_content //'"'//new_line('a') stringed = stringed//'indent: "'//trim(str(self%indent)) //'"'//new_line('a') stringed = stringed//'is self closing: "'//trim(str(self%is_self_closing))//'"'//new_line('a') stringed = stringed//'level: "'//trim(str(self%level)) //'"'//new_line('a') stringed = stringed//'id: "'//trim(str(self%id)) //'"'//new_line('a') stringed = stringed//'parent id: "'//trim(str(self%parent_id)) //'"'//new_line('a') stringed = stringed//'children number: "'//trim(str(self%children_number))//'"'//new_line('a') if (allocated(self%child_id)) stringed = stringed//'children ids: "'//trim(str(self%child_id)) //'"'//new_line('a') else is_content_indented_ = .false. ; if (present(is_content_indented)) is_content_indented_ = is_content_indented only_start_ = .false. ; if (present(only_start)) only_start_ = only_start only_content_ = .false. ; if (present(only_content)) only_content_ = only_content only_end_ = .false. ; if (present(only_end)) only_end_ = only_end if (only_start_) then stringed = self%start_tag(is_indented=is_indented) elseif (only_content_) then if (self%tag_content%is_allocated()) then if (is_content_indented_) then stringed = repeat(' ', self%indent+2)//self%tag_content else stringed = self%tag_content%chars() endif endif elseif (only_end_) then stringed = self%end_tag(is_indented=is_indented) else stringed = '' if (self%tag_name%is_allocated()) then if (self%is_self_closing) then stringed = self%self_closing_tag(is_indented=is_indented) else stringed = self%start_tag(is_indented=is_indented) if (self%tag_content%is_allocated()) then if (is_content_indented_) then stringed = stringed//new_line('a')//repeat(' ', self%indent+2)//& self%tag_content//new_line('a')//repeat(' ', self%indent) else stringed = stringed//self%tag_content endif endif stringed = stringed//self%end_tag() endif endif endif endif endfunction stringify subroutine write_tag(self, unit, is_indented, is_content_indented, form, end_record, only_start, only_content, only_end, & iostat, iomsg) !< Write tag to unit file. class(xml_tag), intent(in) :: self !< XML tag. integer(I4P), intent(in) :: unit !< File unit. logical, intent(in), optional :: is_indented !< Activate content indentation. logical, intent(in), optional :: is_content_indented !< Activate content indentation. character(*), intent(in), optional :: form !< Format. character(*), intent(in), optional :: end_record !< Ending record. logical, intent(in), optional :: only_start !< Write only start tag. logical, intent(in), optional :: only_content !< Write only content. logical, intent(in), optional :: only_end !< Write only end tag. integer(I4P), intent(out), optional :: iostat !< IO status. character(*), intent(out), optional :: iomsg !< IO message. type(string) :: form_ !< Format. type(string) :: end_record_ !< Ending record. integer(I4P) :: iostat_ !< IO status. character(500) :: iomsg_ !< IO message. form_ = 'UNFORMATTED' if (present(form)) then form_ = form form_ = form_%upper() endif end_record_ = '' ; if (present(end_record)) end_record_ = end_record select case(form_%chars()) case('UNFORMATTED') write(unit=unit, iostat=iostat_, iomsg=iomsg_)self%stringify(is_indented=is_indented, & is_content_indented=is_content_indented, & only_start=only_start, & only_content=only_content, & only_end=only_end)//end_record_ case('FORMATTED') write(unit=unit, fmt='(A)', iostat=iostat_, iomsg=iomsg_)self%stringify(is_indented=is_indented, & is_content_indented=is_content_indented, & only_start=only_start, & only_content=only_content, & only_end=only_end)//end_record_ endselect if (present(iostat)) iostat = iostat_ if (present(iomsg)) iomsg = iomsg_ endsubroutine write_tag ! private methods pure subroutine add_single_attribute(self, attribute, sanitize_value) !< Add one attribute name/value pair. !< !< @note Leading and trailing white spaces are trimmed out by attribute's name. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: attribute(1:) !< Attribute name/value pair [1:2]. logical, intent(in), optional :: sanitize_value !< Sanitize attribute value. type(string), allocatable :: new_attribute(:,:) !< Temporary storage for attributes. logical :: sanitize_value_ !< Sanitize attribute value. logical :: is_updated !< Flag to check if the attribute has been updeted. integer(I4P) :: a !< Counter. sanitize_value_ = .false. ; if (present(sanitize_value)) sanitize_value_ = sanitize_value if (self%attributes_number>0) then is_updated = .false. update_if_already_present: do a=1, self%attributes_number if (self%attribute(1, a)==attribute(1)) then if (sanitize_value_) then self%attribute(2, a) = trim(adjustl(attribute(2))) else self%attribute(2, a) = attribute(2) endif is_updated = .true. exit update_if_already_present endif enddo update_if_already_present if (.not.is_updated) then allocate(new_attribute(1:2, 1:self%attributes_number+1)) new_attribute(1:2, 1:self%attributes_number) = self%attribute new_attribute(1, self%attributes_number+1) = trim(adjustl(attribute(1))) if (sanitize_value_) then new_attribute(2, self%attributes_number+1) = trim(adjustl(attribute(2))) else new_attribute(2, self%attributes_number+1) = attribute(2) endif call move_alloc(from=new_attribute, to=self%attribute) self%attributes_number = self%attributes_number + 1 endif else call self%alloc_attributes(Na=1) self%attribute(1, 1) = trim(adjustl(attribute(1))) if (sanitize_value_) then self%attribute(2, 1) = trim(adjustl(attribute(2))) else self%attribute(2, 1) = attribute(2) endif endif endsubroutine add_single_attribute pure subroutine add_multiple_attributes(self, attributes, sanitize_values) !< Add list of attributes name/value pairs. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: attributes(1:,1:) !< Attribute name/value pair list [1:2,1:]. logical, intent(in), optional :: sanitize_values !< Sanitize attribute values. integer(I4P) :: a !< Counter. do a=1, size(attributes, dim=2) ! not efficient: many reallocation, but safe call self%add_single_attribute(attribute=attributes(1:,a), sanitize_value=sanitize_values) enddo endsubroutine add_multiple_attributes pure subroutine add_stream_attributes(self, attributes_stream, sanitize_values) !< Add list of attributes name/value pairs passed as stream. !< !< @note The character `=` cannot compare into the attributes names of values. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: attributes_stream !< Attribute name/value pair list passed as stream. logical, intent(in), optional :: sanitize_values !< Sanitize attribute values. type(string) :: attributes_string !< Attribute name/value pair list as string. type(string) :: tokens(1:3) !< Attributes tokenized by `=`. type(string) :: attribute(1:2) !< Attribute name/value pair. logical :: continue_to_parse !< Sentinel to stop attributes stream parsing. integer(I4P) :: max_chars !< Counter. attributes_string = attributes_stream continue_to_parse = .true. do while(continue_to_parse) tokens = attributes_string%partition(sep='=') attribute(1) = trim(adjustl(tokens(1))) if (attribute(1)/='') then tokens(3) = tokens(3)%slice(istart=tokens(3)%index('"')+1, iend=tokens(3)%len()) attribute(2) = tokens(3)%slice(istart=1, iend=tokens(3)%index('"')-1) tokens(3) = tokens(3)%slice(istart=tokens(3)%index('"')+1, iend=tokens(3)%len()) max_chars = max(attribute(1)%len(), attribute(2)%len()) attribute(1) = attribute(1)%fill(width=max_chars, right=.true., filling_char=' ') attribute(2) = attribute(2)%fill(width=max_chars, right=.true., filling_char=' ') call self%add_single_attribute(attribute=[attribute(1)//'', attribute(2)//''], sanitize_value=sanitize_values) if (tokens(3)%index('=')>0) then attributes_string = tokens(3) else continue_to_parse = .false. endif else continue_to_parse = .false. endif enddo endsubroutine add_stream_attributes elemental subroutine alloc_attributes(self, Na) !< Allocate (prepare for filling) dynamic memory of attributes. class(xml_tag), intent(inout) :: self !< XML tag. integer(I4P), intent(in) :: Na !< Number of attributes. if (allocated(self%attribute)) then call self%attribute%free deallocate(self%attribute) endif allocate(self%attribute(1:2, 1:Na)) self%attributes_number = Na endsubroutine alloc_attributes pure subroutine delete_content(self) !< Delete tag content. class(xml_tag), intent(inout) :: self !< XML tag. call self%tag_content%free endsubroutine delete_content pure subroutine delete_single_attribute(self, name) !< Delete one attribute name/value pair. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: name !< Attribute name. type(string), allocatable :: new_attribute(:,:) !< Temporary storage for attributes. integer(I4P) :: a !< Counter. if (self%attributes_number>0) then search_tag: do a=1, self%attributes_number if (self%attribute(1, a)==name) then if (self%attributes_number>1) then allocate(new_attribute(1:2, 1:self%attributes_number-1)) if (a==1) then new_attribute(:, a:) = self%attribute(:, a+1:) elseif (a==self%attributes_number) then new_attribute(:, :a-1) = self%attribute(:, :a-1) else new_attribute(:, :a-1) = self%attribute(:, :a-1) new_attribute(:, a:) = self%attribute(:, a+1:) endif call move_alloc(from=new_attribute, to=self%attribute) else call self%attribute%free deallocate(self%attribute) endif self%attributes_number = self%attributes_number - 1 exit search_tag endif enddo search_tag endif endsubroutine delete_single_attribute pure subroutine delete_multiple_attributes(self, name) !< Delete list of attributes name/value pairs. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: name(1:) !< Attributes names. integer(I4P) :: a !< Counter. do a=1, size(name, dim=1) call self%delete_single_attribute(name=name(a)) enddo endsubroutine delete_multiple_attributes elemental subroutine get(self, source) !< Get the tag content and attributes from source after tag_name and attributes names have been set. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: source !< String containing data. call self%get_value(source=source) call self%get_attributes(source=source) ! call self%get_nested() endsubroutine get elemental subroutine get_attributes(self, source) !< Get the attributes values from source after tag_name and attributes names have been set. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: source !< String containing data. integer :: a !< Counter. integer :: c1 !< Counter. integer :: c2 !< Counter. if (index(string=source, substring='<'//self%tag_name)>0) then if (self%attributes_number>0) then ! parsing attributes do a=1, self%attributes_number c1 = index(string=source, substring=self%attribute(1, a)//'="') + self%attribute(1, a)%len() + 2 if (c1>self%attribute(1, a)%len() + 2) then c2 = index(string=source(c1:), substring='"') if (c2>0) then self%attribute(2, a) = source(c1:c1+c2-2) else call self%attribute(2, a)%free endif else call self%attribute(2, a)%free endif enddo endif endif endsubroutine get_attributes elemental subroutine get_value(self, source) !< Get the tag value from source after tag_name has been set. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: source !< String containing data. integer :: c1 !< Counter. integer :: c2 !< Counter. call self%tag_content%free self%is_self_closing = .false. if (index(string=source, substring='<'//self%tag_name)>0) then c2 = index(string=source, substring='</'//self%tag_name//'>') if (c2>0) then ! parsing tag value c1 = index(string=source, substring='>') if (c1+1<c2-1) self%tag_content = source(c1+1:c2-1) else self%is_self_closing = .true. endif endif endsubroutine get_value elemental subroutine parse_attributes_names(self, source) !< Parse the tag attributes names contained into a string. !< !< Valid syntax is: !< + `att1="att1 val" att2="att2 val"...` !< @note Inside the attributes value the symbols `<` and `>` are not allowed. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: source !< String containing the input. character(len=:), allocatable :: att !< Dummy string for parsing file. integer(I4P) :: c !< Counter. integer(I4P) :: s !< Counter. integer(I4P) :: a !< Counter. integer(I4P) :: Na !< Counter. Na = 0 c = 1 att_count: do while(c<=len(source)) if (source(c:c)=='=') Na = Na + 1 c = c + 1 enddo att_count if (Na>0) then call self%alloc_attributes(Na=Na) c = index(string=source, substring=' ') att = source(c:) c = 1 a = 1 att_search: do while(c<=len(att)) if (att(c:c)=='=') then s = max(0, index(string=att, substring=' ')) self%attribute(1, a) = trim(adjustl(att(s+1:c-1))) att = att(c+1:) c = 1 a = a + 1 endif c = c + 1 enddo att_search endif endsubroutine parse_attributes_names elemental subroutine search(self, tag_name, source, tstart, tend) !< Search tag named *tag_name* into a string and, in case it is found, store into self. !< !< @note If *tag_name* is not found, self is returned empty. class(xml_tag), intent(inout) :: self !< XML tag. character(*), intent(in) :: tag_name !< Searched tag name. character(*), intent(in) :: source !< String containing the input. integer(I4P), optional, intent(out) :: tstart !< Starting index of tag inside the source. integer(I4P), optional, intent(out) :: tend !< Ending index of tag inside the source. type(xml_tag) :: tag !< Dummy XML tag. integer(I4P) :: tstart_ !< Starting index of tag inside the source, local variable. integer(I4P) :: tend_ !< Ending index of tag inside the source, local variable. logical :: found !< Flag for inquiring search result. integer(I4P) :: tstart_c !< Starting index of tag inside the current slice of source. integer(I4P) :: tend_c !< Starting index of tag inside the current slice of source. integer(I4P) :: i call self%free self%tag_name = tag_name tstart_ = 1 tend_ = 0 found = .false. tstart_c = 0 tend_c = 0 tag_search: do call tag%parse(source=source(tend_ + 1:), tstart=tstart_c, tend=tend_c) tstart_ = tstart_ + tend_ tend_ = tend_ + tend_c if (tstart_c==0.and.tend_c==0) then exit tag_search ! no tag found else if (tag%tag_name%is_allocated()) then if (tag%tag_name==self%tag_name) found = .true. endif endif if (found) exit tag_search enddo tag_search if (found) then self = tag else call self%free endif if (present(tstart)) tstart = tstart_ if (present(tend )) tend = tend_ endsubroutine search ! assignment (=) elemental subroutine assign_tag(lhs, rhs) !< Assignment between two tags. class(xml_tag), intent(inout) :: lhs !< Left hand side. type(xml_tag), intent(in) :: rhs !< Right hand side. integer(I4P) :: a !< Counter. call lhs%free if (rhs%tag_name%is_allocated()) lhs%tag_name = rhs%tag_name if (rhs%tag_content%is_allocated()) lhs%tag_content = rhs%tag_content lhs%pos = rhs%pos if (rhs%attributes_number>0) then allocate(lhs%attribute(1:2, 1:rhs%attributes_number)) do a=1, rhs%attributes_number lhs%attribute(1:2, a) = rhs%attribute(1:2, a) enddo endif lhs%attributes_number = rhs%attributes_number lhs%indent = rhs%indent lhs%is_self_closing = rhs%is_self_closing lhs%level = rhs%level lhs%id = rhs%id lhs%parent_id = rhs%parent_id lhs%children_number = rhs%children_number if (allocated(rhs%child_ID)) lhs%child_ID = rhs%child_ID endsubroutine assign_tag ! finalize elemental subroutine finalize(tag) !< Free dynamic memory when finalizing. type(xml_tag), intent(inout) :: tag !< XML tag. call tag%free endsubroutine finalize endmodule foxy_xml_tag