! dc_url.f90 - 変数 URL の文字列解析
! Copyright (C) GFD Dennou Club, 2000.  All rights reserved

module dc_url

    use dcstring_base, only: VSTRING, operator(.cat.), operator(/=), &
       extract, operator(==)
    implicit none

    public:: UrlSplit, UrlResolve, Url_Chop_iorange

    interface UrlMerge
        module procedure url_merge_v_vvv
        module procedure url_merge_cccc
        module procedure url_merge_cc
    end interface

    interface UrlSplit
        module procedure url_split_v
        module procedure url_split_c
    end interface

    interface UrlResolve
        module procedure url_resolve_c
    end interface

    interface operator(.OnTheSameFile.)
        module procedure UrlOnTheSameFile
    end interface

    character, public, parameter:: GT_ATMARK = "@"
    character, public, parameter:: GT_COLON = ":"
    character, public, parameter:: GT_COMMA = ","
    character, public, parameter:: GT_QUESTION = '?'
    character, public, parameter:: GT_EQUAL = "="
    character, public, parameter:: GT_CIRCUMFLEX = "^"
    character, public, parameter:: GT_PLUS = "+"

contains

    ! ANUrlMerge - 変数 URL の合成
    ! 空文字列の成分はないとみなされる。

        type(VSTRING) function &
    url_merge_v_vvv(file, var, attr, iorange) result(result)
        type(VSTRING), intent(in):: file
        type(VSTRING), intent(in), optional:: var
        type(VSTRING), intent(in), optional:: attr
        type(VSTRING), intent(in), optional:: iorange
        result = file .cat. GT_ATMARK
        if (present(var)) result = result .cat. var
        if (present(attr)) then
            if (attr /= "") result = result .cat. GT_COLON .cat. attr
        endif
        if (present(iorange)) then
            if (extract(iorange, 1, 1) == GT_COMMA) then
                result = result .cat. iorange
            else if (iorange /= "") then
                result = result .cat. GT_COMMA .cat. iorange
            endif
        endif
    end function

    function url_merge_cccc(file, var, attr, iorange) result(result)
        use dc_types, only: string
        character(len = string):: result
        character(len = *), intent(in):: file
        character(len = *), intent(in):: var
        character(len = *), intent(in):: attr
        character(len = *), intent(in):: iorange
    continue
        if (file /= "") then
            result = trim(file) // gt_atmark
        else
            result = gt_atmark
        endif
        if (var /= "") result = trim(result) // var
        if (attr /= "") then
            result = trim(result) // gt_colon // attr
        endif
        if (iorange /= "") then
            if (iorange(1:1) == gt_comma) then
                result = trim(result) // iorange
            else
                result = trim(result) // gt_comma // iorange
            endif
        endif
    end function

    function url_merge_cc(file, var) result(result)
        use dc_types, only: string
        character(len = string):: result
        character(len = *), intent(in):: file
        character(len = *), intent(in):: var
    continue
        result = url_merge_cccc(file, var, "", "")
    end function

    ! Url_Chop_iorange - 変数 URL から iorange を除去
    subroutine url_chop_iorange(fullname, iorange, remainder)
        use dc_types, only: string
        character(len = *), intent(in):: fullname
        character(len = *), intent(out):: iorange, remainder
        character(string):: file, var, attr
        call urlsplit(fullname, file=file, var=var, attr=attr, iorange=iorange)
        remainder = url_merge_cccc(file=file, var=var, attr=attr, iorange="")
    end subroutine

    ! UrlSplit - 変数 URL の分解
    ! 見つからない成分には空文字列が代入される。

    subroutine url_split_c(fullname, file, var, attr, iorange)
        use dc_types, only: string
        character(len = *), intent(in):: fullname
        character(len = *), intent(out), optional:: file, var, attr, iorange
        character(len = string):: varpart
        integer:: atmark, colon, comma
        character(len = *), parameter:: VARNAME_SET &
            = "0123456789eEdD+-=^,.:_" &
            // "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
            // "abcdefghijklmnopqrstuvwxyz"
    continue
        ! まず URL と変数属性指定 (? または @ 以降) を分離する。
        ! URL は @ を含みうるため、最後の @ 以降に対して変数属性
        ! として許されない文字（典型的には '/'）が含まれていたら
        ! 当該 @ は URL の一部とみなす。
        atmark = index(fullname, GT_QUESTION)
        if (atmark == 0) then
            atmark = index(fullname, GT_ATMARK, back=.TRUE.)
            if (atmark /= 0) then
                if (verify(trim(fullname(atmark+1: )), VARNAME_SET) /= 0) then
                    atmark = 0
                endif
            endif
        endif
        if (atmark == 0) then
            ! 変数属性指定はなかった。
            if (present(file)) file = fullname
            if (present(var)) var = ''
            if (present(attr)) attr = ''
            if (present(iorange)) iorange = ''
            return
        endif
        varpart = fullname(atmark+1: )
        ! 変数属性指定があった。
        if (present(file)) file = fullname(1: atmark - 1)
        ! 範囲指定を探索する。
        comma = index(varpart, GT_COMMA)
        if (comma /= 0) then
            ! 範囲指定がみつかった。
            if (present(var)) var = varpart(1: comma - 1)
            if (present(attr)) attr = ''
            if (present(iorange)) iorange = varpart(comma + 1: )
            return
        endif
        if (present(iorange)) iorange = ''
        ! 範囲指定がなかったので、属性名の検索をする。
        colon = index(varpart, GT_COLON)
        if (colon == 0) then
            if (present(var)) var = varpart
            if (present(attr)) attr = ''
            varpart = ''
            return
        endif
        if (present(var)) var = varpart(1: colon - 1)
        if (present(attr)) attr = varpart(colon + 1: )
        varpart = ''
    end subroutine

    subroutine url_split_v(fullname, file, var, attr, iorange)
        use dc_string
        type(VSTRING), intent(in):: fullname
        type(VSTRING), intent(out), optional::        file, var, attr, iorange
        type(VSTRING):: varpart
        integer:: atmark, colon, comma
        character(len = *), parameter:: VARNAME_SET &
            = "0123456789eEdD+-=^,.:_" &
            // "ABCDEFGHIJKLMNOPQRSTUVWXYZ" &
            // "abcdefghijklmnopqrstuvwxyz"
    continue
        ! まず URL と変数属性指定 (? または @ 以降) を分離する。
        ! URL は @ を含みうるため、最後の @ 以降に対して変数属性
        ! として許されない文字（典型的には '/'）が含まれていたら
        ! 当該 @ は URL の一部とみなす。
        atmark = vindex(fullname, GT_QUESTION)
        if (atmark == 0) then
            atmark = vindex(fullname, GT_ATMARK, .TRUE.)
            if (atmark /= 0) then
                varpart = extract(fullname, atmark + 1)
                if (vverify(varpart, VARNAME_SET) /= 0) then
                    atmark = 0
                endif
            endif
        endif
        if (atmark == 0) then
            ! 変数属性指定はなかった。
            if (present(file)) file = fullname
            if (present(var)) var = ''
            if (present(attr)) attr = ''
            if (present(iorange)) iorange = ''
            return
        endif
        varpart = extract(fullname, atmark + 1)
        ! 変数属性指定があった。
        if (present(file)) file = extract(fullname, 1, atmark - 1)
        ! 範囲指定を探索する。
        comma = vindex(varpart, GT_COMMA)
        if (comma /= 0) then
            ! 範囲指定がみつかった。
            if (present(var)) var = extract(varpart, 1, comma - 1)
            if (present(attr)) attr = ''
            if (present(iorange)) iorange = extract(varpart, comma + 1)
            return
        endif
        if (present(iorange)) iorange = ''
        ! 範囲指定がなかったので、属性名の検索をする。
        colon = vindex(varpart, GT_COLON)
        if (colon == 0) then
            if (present(var)) var = varpart
            if (present(attr)) attr = ''
            varpart = ''
            return
        endif
        if (present(var)) var = extract(varpart, 1, colon - 1)
        if (present(attr)) attr = extract(varpart, colon + 1)
        varpart = ''
    end subroutine

    !
    ! === 同じファイルに載っているかどうか判定 ===
    !

    logical function UrlOnTheSameFile(url_a, url_b) result(result)
        use dc_string
        use dc_types, only: string
        character(len = *), intent(in) :: url_a
        character(len = *), intent(in) :: url_b
        character(len = STRING)        :: filepart_a
        character(len = STRING)        :: filepart_b
        call UrlSplit(url_a, file=filepart_a)
        call UrlSplit(url_b, file=filepart_b)
        result = (filepart_a == filepart_b)
    end function

    !
    ! === 相対リンクを解決 ===
    !

    function url_resolve_c(relative, base) result(result)
        use dc_string, only: StrHead
        use dc_types, only: string
        use dc_trace, only: beginsub, endsub, DbgMessage
    implicit none
        character(len = *), intent(in):: relative
        character(len = *), intent(in):: base
        character(len = STRING):: result
        integer, parameter:: FILE = 1, VAR = 2, ATTR = 3, IOR = 4
        character(len = STRING):: rel(FILE:IOR), bas(FILE:IOR)
        character(3), parameter:: PATHDELIM = "/:" // achar(94)
        integer:: idir_r, idir_b
    continue
        call beginsub('urlresolve', 'rel=<%c> base=<%c>', c1=relative, c2=base)
        call UrlSplit(trim(relative), file=rel(FILE), var=rel(VAR), &
            & attr=rel(ATTR), iorange=rel(IOR))
        call DbgMessage('rel -> file=<%c> var=<%c> attr=<%c>', &
            & c1=trim(rel(FILE)), c2=trim(rel(VAR)), &
            & c3=(trim(rel(ATTR)) // '> ior=<' // trim(rel(IOR))))
        call UrlSplit(base, file=bas(FILE), var=bas(VAR), &
            & attr=bas(ATTR), iorange=bas(IOR))
        call DbgMessage('base -> file=<%s> var=<%s> attr=<%s> ior=<%s>', &
            & c1=trim(bas(FILE)), c2=trim(bas(VAR)), &
            & c3=(trim(bas(ATTR)) // '> ior=<' // trim(bas(IOR))))
        ! --- ファイル名を欠くばあいは単に補う ---
        if (rel(FILE) == "") then
            rel(FILE) = bas(FILE)
            if (rel(VAR) == "") &
                & rel(VAR) = bas(VAR)
            result = UrlMerge(file=rel(FILE), var=rel(VAR), &
                    & attr=rel(ATTR), iorange=rel(IOR))
            call endsub('urlresolve', '1 result=%c', c1=trim(result))
            return
        endif
        ! --- 絶対パス (と見られる) ファイル名はそのまま使用 ---
        if (StrHead(rel(FILE), "file:") &
            & .OR. StrHead(rel(FILE), "http:") &
            & .OR. StrHead(rel(FILE), "ftp:") &
            & .OR. StrHead(rel(FILE), "news:") &
            & .OR. StrHead(rel(FILE), "www") &
            & .OR. StrHead(rel(FILE), "/") &
            & .OR. StrHead(rel(FILE), achar(94)) &
            & .OR. rel(FILE)(2:2) == ":" &
            ) then
            result = relative
            call endsub('urlresolve', '2 result=%c', c1=trim(result))
            return
        endif
        ! ディレクトリ名の取り出し
        idir_b = scan(bas(FILE), PATHDELIM, back=.TRUE.) 
        if (idir_b == 0) then
            ! が、できなければ、（エラーとすべきかもしれぬが）
            ! 相対パスをそのまま使用
            result = relative
            call endsub('urlresolve', '3 result=%c', c1=trim(result))
            return
        endif
        ! 相対パスのほうのディレクトリ名の取り出し
        idir_r = scan(rel(FILE), PATHDELIM, back=.TRUE.)
        if (idir_r == 0) then
            ! ができなければ全体を使用
            idir_r = 1
        endif
        result = base(1: idir_b) // relative(idir_r: )
        call endsub('urlresolve', '4 result=%c', c1=trim(result))
    end function

end module