path: root/pptxml.f90

! Copyright (c) 2022 Approximatrix, LLC <support@approximatrix.com>
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! The Software shall be used for Good, not Evil.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module fpoint_pptxml
use FoX_dom
implicit none

    private
    public::slide

    integer, parameter::list_single_bullet_max_length = 512

    integer, parameter::SLIDENUM_UNKNOWN        = 0
    integer, parameter::SLIDENUM_DOESNOTEXIST   = -1
    integer, parameter::SLIDENUM_ERRORPARSING   = -2

    character(*), parameter::presentation_schema = "http://schemas.openxmlformats.org/presentationml/2006/main"
    character(*), parameter::drawing_schema = "http://schemas.openxmlformats.org/drawingml/2006/main"

    type::slide

        integer::number
        
        character(len=:), pointer::title

        type(Node), pointer::slide_dom
        class(element), pointer::content

        contains 
            
        procedure :: load => slide_load_filename
        procedure :: to_text => slide_to_text
        procedure :: text_length => slide_text_length
        
    end type slide
    
    type, abstract::element
        class(element), pointer :: next
        contains
        procedure(from_node), deferred :: from_node
        procedure(to_text), deferred :: to_text
        procedure :: length => element_text_length
    end type element
    
    abstract interface
        function to_text(self)
        import::element
        class(element), intent(in)::self
        character(len=:), pointer::to_text
        end function to_text
    end interface
    
    abstract interface
        subroutine from_node(self, n)
        use FoX_dom
        import::element
        class(element), intent(inout)::self
        type(Node), pointer::n
        end subroutine from_node
    end interface
    
    type, extends(element)::text_element
        character(len=:), pointer::text
        contains
        procedure::to_text => text_element_to_text
        procedure::from_node => text_element_from_node
    end type text_element
    
    type, extends(text_element)::heading_element
        contains
        procedure::to_text => heading_element_to_text
    end type heading_element
    
    type, extends(element)::list_element
        character(len=list_single_bullet_max_length), dimension(:), pointer::text
        contains
        procedure::to_text => list_element_to_text
        procedure::from_node => list_element_from_node
    end type list_element
    
contains

    function get_child_text(n) result(t)
    use FoX_dom
    implicit none
    
        type(Node), pointer::n, tn
        character(len=:), pointer::t, resize_t
        type(NodeList), pointer::text_nodes
        
        text_nodes => getElementsByTagNameNS(n, drawing_schema, "t")
        if(getLength(text_nodes) >= 1) then
            tn => item(text_nodes, 0)
            allocate(character(len=1024) :: resize_t)
            call extractDataContent(tn, resize_t)
            allocate(character(len=len_trim(resize_t)) :: t)
            t = resize_t
            deallocate(resize_t)
        end if
        
    end function get_child_text
    
    function find_slide_title(dom) result(t)
    use FoX_dom
    implicit none
    
        type(Node), pointer::dom
        character(len=:), pointer::t
    
        type(NodeList), pointer::nonvis_props
        type(Node), pointer::one_props, sp, nonvis_sp
        character(len=6)::temp
        integer::i
    
        t => null()
        nonvis_props => getElementsByTagNameNS(dom, presentation_schema, "cNvPr")
        
        do i=1, getLength(nonvis_props)
            one_props => item(nonvis_props, i-1)
            if(hasAttribute(one_props, "name")) then
                temp = getAttribute(one_props, "name")
                if(temp(1:6) == "Title ") then
                    exit
                end if
            end if
            one_props => null()
        end do
        
        if(associated(one_props)) then
            nonvis_sp => getParentNode(one_props)
            sp => getParentNode(nonvis_sp)
            if(associated(sp)) then
                t => concatenated_text_in_rows(getElementsByTagNameNS(sp, drawing_schema, "r"))
            end if
        end if
        
    end function find_slide_title

    function parse_one_sp_node(n) result(e)
    use FoX_dom
    implicit none
    
        type(Node), pointer::n
        class(element), pointer::e
        
        type(heading_element), pointer::he
        type(text_element), pointer::te
        type(list_element), pointer::le
        
        type(NodeList), pointer::nonvis_sp, bullet_defns
        type(Node), pointer::prop_node
        
        integer::i
        
        e => null()
        
        nonvis_sp => getElementsByTagNameNS(n, presentation_schema, "cNvPr")
        do i=1, getLength(nonvis_sp) 
            prop_node => item(nonvis_sp, i-1)
            
            ! Try based on property name
            if(hasAttribute(prop_node, "name")) then
                
                ! if "Title" or "Subtitle" is present
                if(index(getAttribute(prop_node, "name"), "itle") > 0) then
                    allocate(he)
                    call he%from_node(n)
                    e => he
                    exit
                end if
            
            end if
            
        end do
        
        ! Next, check for bullets
        if(.not. associated(e)) then
            bullet_defns => getElementsByTagNameNS(n, drawing_schema, "cNvPr")
            if(associated(bullet_defns)) then
                if(getLength(bullet_defns) > 0) then
                    allocate(le)
                    call le%from_node(n)
                    e => le
                end if
            end if
        end if
        
        if(.not. associated(e)) then
            bullet_defns => getElementsByTagNameNS(n, drawing_schema, "lstStyle")
            if(associated(bullet_defns)) then
                if(getLength(bullet_defns) > 0) then
                    allocate(le)
                    call le%from_node(n)
                    e => le
                end if
            end if
        end if
        
        ! Finally, try treating as a text node
        if(.not. associated(e)) then
            allocate(te)
            call te%from_node(n)
            e=>te
        end if
        
        if(associated(e)) then
            if(e%length() == 0) then
                deallocate(e)
                e => null()
            else
                e%next => null()
            end if
        end if

    end function parse_one_sp_node
    
    recursive function walk_sp_tree(parent) result(elements)
    use FoX_dom
    implicit none
    
        type(Node), pointer::parent
        class(element), pointer::elements
        
        type(Node), pointer::one_child
        type(NodeList), pointer::child_nodes
        class(element), pointer::child_elements, walker
        integer::i
        type(DomException)::fex
        character(32)::tname
        
        elements => null()
        
        child_nodes => getChildNodes(parent)
        do i = 1, getLength(child_nodes)
            one_child => item(child_nodes, i-1)
            
            child_elements => null()
            
            tname = getTagName(one_child, fex)
            
            if(.not. inException(fex)) then
                ! Single sp
                if(trim(tname) == "p:sp") then
                    child_elements => parse_one_sp_node(one_child)
                
                ! A group of sp's
                elseif(trim(tname) == "p:grpSp") then
                    child_elements => walk_sp_tree(one_child)
                    
                end if
                
                if(associated(child_elements)) then
                
                    ! Append
                    if(associated(elements)) then

                        walker => elements
                        do while(associated(walker%next))
                            walker => walker%next
                        end do
                        walker%next => child_elements
                    
                    ! First one!
                    else
                        elements => child_elements
                    end if
                    
                end if
            end if
            
        end do
    
    end function walk_sp_tree
    
    subroutine parse_slide_sp(self)
    use FoX_dom
    implicit none
    
        class(slide), intent(inout)::self
        
        type(NodeList), pointer::nl
        type(Node), pointer::sptree
        
        nl => getElementsByTagNameNS(self%slide_dom, &
                                     presentation_schema, "spTree")
        
        self%content => null()
        if(associated(nl)) then
            if(getLength(nl) >= 1) then
                sptree => item(nl, 0)
                self%content => walk_sp_tree(sptree)
            end if
        end if
    
    end subroutine parse_slide_sp

    subroutine slide_load_filename(self, filename, title)
    use FoX_dom
    implicit none
    
        class(slide), intent(out)::self
        character(len=*), intent(in)::filename
        character(len=*), intent(in), optional::title
        
        character(len=:), pointer::filename_no_backslashes
        
        ! For parsing the title out
        type(NodeList), pointer::sp_elements
        type(Node), pointer::title_parent
        
        integer::ext, startnum, ios
        logical::existence
        
        integer::i
        
        class(element), pointer::walker, tmp
        
        self%number = SLIDENUM_UNKNOWN

        inquire(file=filename, exist=existence)
        if(.not. existence) then
            self%number = SLIDENUM_DOESNOTEXIST
            return
        end if
        
        ext = index(filename, ".xml", back=.true.)
        if(ext >= 1) then
            startnum = index(filename(1:ext), "slide", back=.true.)
            if(startnum >= 1) then
                startnum = startnum + 5
                read(filename(startnum:ext-1), *, iostat=ios) self%number
            end if
        end if
        
        ! Now actually load the xml
        if(index(filename, "\") > 0) then
            allocate(character(len=len_trim(filename))::filename_no_backslashes)
            filename_no_backslashes = filename
            i = index(filename_no_backslashes, '\')
            do while(i > 0)
                filename_no_backslashes(i:i) = '/'
                i = index(filename_no_backslashes, '\')
            end do
            ! This was all very stupid...
            self%slide_dom => parseFile(filename_no_backslashes)
            deallocate(filename_no_backslashes)
        else
            self%slide_dom => parseFile(filename)
        end if
        if(.not. associated(self%slide_dom)) then
            self%number = SLIDENUM_ERRORPARSING
            return
        end if

        if(present(title)) then
            allocate(character(len=len_trim(title)) :: self%title)
            self%title = title
        else
            self%title => find_slide_title(self%slide_dom)
            if(.not. associated(self%title) .and. self%number > 0) then
                allocate(character(len=16)::self%title)
                write(self%title, '(I8)') self%number
                self%title = "Slide "//trim(adjustl(self%title))
            end if
        end if
        
        call parse_slide_sp(self)
        
        ! This gets rid of double-accounting for the title
        if(associated(self%content) .and. associated(self%title)) then
            tmp => null()
            walker => self%content
            do while(associated(walker))
                if(self%content%to_text() == "## "//self%title) then
                    if(.not.associated(tmp)) then
                        self%content => walker%next
                    else
                        tmp%next => walker%next
                    end if
                    deallocate(walker)
                    exit
                end if
                tmp => walker
                walker => walker%next
            end do
        end if
        
    end subroutine slide_load_filename

    function element_text_length(self)
    implicit none
    
        class(element), intent(in)::self
        integer::element_text_length
        character(len=:), pointer::text_temp
        
        text_temp => self%to_text()
        if(associated(text_temp)) then
            element_text_length = len_trim(text_temp)
            deallocate(text_temp)
        else
            element_text_length = 0
        end if
        
    end function element_text_length
    
    function heading_element_to_text(self) result(t)
    implicit none
    
        class(heading_element), intent(in)::self
        character(len=:), pointer::t

        t => null()
        if(associated(self%text)) then
            allocate(character(len=len_trim(self%text)+3) :: t)
            t = "## "//self%text
        end if
        
    end function heading_element_to_text
    
    function text_element_to_text(self) result(t)
    implicit none
    
        class(text_element), intent(in)::self
        character(len=:), pointer::t

        t => null()
        if(associated(self%text)) then
            allocate(character(len=len_trim(self%text)) :: t)
            t = self%text
        end if
    end function text_element_to_text
    
    function concatenated_text_in_row(r) result(t)
    use FoX_dom
    implicit none
    
        type(Node), pointer::r
        character(len=:), pointer::t
        type(NodeList), pointer::text_nodes
        type(Node), pointer::tn, bairn
        integer::i, text_length, j
        
        text_length = 0
        text_nodes => getElementsByTagNameNS(r, drawing_schema, "t")
        do i = 1, getLength(text_nodes)
            tn => item(text_nodes, i-1)
            do j = 1, getLength(getChildNodes(tn))
                bairn => item(getChildNodes(tn), i-1)
                text_length = text_length + len(getNodeValue(bairn))
            end do
        end do
        
        allocate(character(len=text_length)::t)
        text_length = 1
        do i = 1, getLength(text_nodes)
            tn => item(text_nodes, i-1)
            do j = 1, getLength(getChildNodes(tn))
                bairn => item(getChildNodes(tn), i-1)
                
                t(text_length:len(t)) = getNodeValue(bairn)
                text_length = text_length + len(getNodeValue(bairn))
            end do
            
        end do
    
    end function concatenated_text_in_row
    
    function concatenated_text_in_rows(rows) result(t)
    implicit none
    
        type(NodeList), pointer::rows
        character(len=:), pointer::t
        
        character(len=:), pointer::one_row_text
        integer::i, text_length
        
        t => null()
        if(getLength(rows) == 0) then
            return
        end if
        
        text_length = 0
        do i = 1, getLength(rows)
            one_row_text => concatenated_text_in_row(item(rows, i-1))
            if(associated(one_row_text)) then
                text_length = text_length + len(one_row_text)
                deallocate(one_row_text)
            end if
        end do
        
        allocate(character(len=text_length) :: t)
        text_length = 1
        do i = 1, getLength(rows)
            one_row_text => concatenated_text_in_row(item(rows, i-1))
            if(associated(one_row_text)) then
                t(text_length:len(t)) = one_row_text
                text_length = text_length + len(one_row_text)
                deallocate(one_row_text)
            end if
        end do
        
    end function concatenated_text_in_rows
    
    subroutine text_element_from_node(self, n)
    use FoX_dom
    implicit none
    
        class(text_element), intent(inout)::self
        type(Node), pointer::n
        type(NodeList), pointer::rows, paras
        character(len=:), pointer::one_para
        integer::text_length, i
        
        text_length = 0
        paras => getElementsByTagNameNS(n, drawing_schema, "p")
        do i = 1, getLength(paras)
            rows => getElementsByTagNameNS(item(paras, i-1), drawing_schema, "r")
            one_para => concatenated_text_in_rows(rows)
            if(associated(one_para)) then
                text_length = text_length + len_trim(one_para)
                if(i /= getLength(paras)) then
                    text_length = text_length + len(new_line(' '))
                end if
            end if
        end do
        
        allocate(character(len=text_length) :: self%text)
        
        text_length = 1
        paras => getElementsByTagNameNS(n, drawing_schema, "p")
        do i = 1, getLength(paras)
            rows => getElementsByTagNameNS(item(paras, i-1), drawing_schema, "r")
            one_para => concatenated_text_in_rows(rows)
            if(associated(one_para)) then
                self%text(text_length:len(self%text)) = one_para
                text_length = text_length + len_trim(one_para)
                if(i /= getLength(paras)) then
                    self%text(text_length:len(self%text)) = new_line(' ')
                    text_length = text_length + len(new_line(' '))
                end if
            end if
        end do
        
    end subroutine text_element_from_node
    
    function slide_to_text(self) result(t)
    implicit none
    
        class(slide), intent(in)::self
        character(len=:), pointer::t
        
        character(len=:), pointer::one_element
        class(element), pointer::walker
        integer::text_length
        
        text_length = 0
        walker => self%content
        do while(associated(walker))
            text_length = text_length + walker%length() + 2*len(new_line(' '))
            walker => walker%next
        end do
        
        if(associated(self%title)) then
            text_length = text_length + 2 + len_trim(self%title) + 2*len(new_line(' ')) + 2
        end if
        
        allocate(character(len=text_length) :: t)
        t = " "
        text_length = 1
        
        if(associated(self%title)) then
            t = "# "//trim(self%title)//repeat(new_line(' '),2)
            text_length = text_length + 2 + len_trim(self%title) + 2*len(new_line(' '))
        end if
        
        walker => self%content
        do while(associated(walker))
            one_element => walker%to_text()
            if(associated(one_element)) then
                t(text_length:len(t)) = one_element//repeat(new_line(' '),2)
                text_length = text_length + len_trim(one_element) + 2*len(new_line(' '))
                deallocate(one_element)
            end if
            walker => walker%next
        end do
    
    end function slide_to_text
        
    function slide_text_length(self)
    implicit none
    
        class(slide), intent(in)::self
        integer::slide_text_length
        
        character(len=:), pointer::tmp
        
        tmp => self%to_text()
        if(associated(tmp)) then
            slide_text_length = len_trim(tmp)
        else
            slide_text_length =  0
        end if
        
    end function slide_text_length
        
    subroutine list_element_from_node(self, n)
    use FoX_dom
    implicit none
    
        class(list_element), intent(inout)::self
        type(Node), pointer::n
        
        character(len=:), pointer::one_text
        integer::i, j
        type(NodeList), pointer::p_nodes, row_nodes
        type(Node), pointer:: one_p
        
        character(len=list_single_bullet_max_length), dimension(:), pointer::tmp
        
        p_nodes => getElementsByTagNameNS(n, drawing_schema, "p")
        allocate(tmp(getLength(p_nodes)))
        tmp = " "
        
        j = 0
        do i = 1, getLength(p_nodes)
            one_p => item(p_nodes, i-1)
            row_nodes => getElementsByTagNameNS(one_p, drawing_schema, "r")
            one_text => concatenated_text_in_rows(row_nodes)
            if(associated(one_text)) then
                if(len_trim(one_text) > 0) then
                    j = j + 1
                    tmp(j) = one_text
                end if
                deallocate(one_text)
            end if
        end do
        
        ! j now holds the number of bullets with actual text
        allocate(self%text(j))
        self%text = tmp(1:j)
        deallocate(tmp)
        
    end subroutine list_element_from_node
    
    function list_element_to_text(self) result(t)
    implicit none
    
        class(list_element), intent(in)::self
        character(len=:), pointer::t
    
        integer::i, text_length
    
        t => null()
        if(.not. associated(self%text)) then
            return
        end if
    
        text_length = 0
        do i = 1, size(self%text)
            text_length = text_length + &
                          len_trim(self%text(i)) + &
                          len(new_line(' ')) + 2
        end do
        
        allocate(character(len=text_length) :: t)
        t = " "
        
        text_length = 1
        do i = 1, size(self%text)
            if(i < size(self%text)) then
                t(text_length:len(t)) = "* "//trim(self%text(i))//new_line(' ')
                text_length = text_length + len(new_line(' ')) + len_trim(self%text(i))+2
            else
                t(text_length:len(t)) = "* "//trim(self%text(i))
            end if
        end do
    
    end function list_element_to_text

end module fpoint_pptxml