!# This source file is distributed with code Pégase.3.0.1 (2019-02-21).
!# Copyright: Michel Fioc (Michel.Fioc@iap.fr), Sorbonne université, 
!# Institut d'astrophysique de Paris/CNRS, France.
!# 
!# Pégase.3.0.1 is governed by the CeCILL license under French law and abides 
!# by the rules of distribution of free software. You can use, modify and/or 
!# redistribute this software under the terms of the CeCILL license as circulated 
!# by CEA, CNRS and INRIA at "http://www.cecill.info". The text of this license
!# is also available in French and in English in directory "doc_dir/" of this
!# code.
!# 
!# As a counterpart to the access to the source code and to the rights to copy,
!# modify and redistribute it granted by the license, users are provided only
!# with a limited warranty, and the software's author, the holder of the
!# economic rights, and the successive licensors have only limited
!# liability. 
!# 
!# The fact that you are presently reading this means that you have had
!# knowledge of the CeCILL license and that you accept its terms.
!#====================================================================== 

module mod_strings

  use mod_types, only : long_string
  implicit none
  private

  interface quote_string
     module procedure quote_string1, quote_string2
  end interface quote_string

  character, parameter, public :: HT = achar(9) !# Horizontal tabulation.
  character, parameter :: NAK = achar(6) !# Negative-acknowledge character.

  integer, parameter :: shift = iachar("a")-iachar("A")

  public :: down_case, up_case, untabify, quote_string, same_case_equal, &
       find_closing_quote, unquote_string

contains

!#======================================================================

  function down_case(string) !# Replace uppercase characters by lowercase ones.

    implicit none
    character(len=*), intent(in) :: string
    character(len=len(string)) :: down_case
!#......................................................................
    integer :: i
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    do i = 1, len(string)
       if (string(i:i) >= "A" .and. string(i:i) <= "Z") then
          down_case(i:i) = achar(iachar(string(i:i))+shift)
       else
          down_case(i:i) = string(i:i)
       endif
    enddo

  end function down_case

!#======================================================================

  function up_case(string) !# Replace lowercase characters by uppercase ones.

    implicit none
    character(len=*), intent(in) :: string
    character(len=len(string)) :: up_case
!#......................................................................
    integer :: i
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    do i = 1, len(string)
       if (string(i:i) >= "A" .and. string(i:i) <= "Z") then
          up_case(i:i) = achar(iachar(string(i:i))-shift)
       else
          up_case(i:i) = string(i:i)
       endif
    enddo

  end function up_case

!#======================================================================

  function untabify(string) !# Replace each horizontal tabulation by one space.

    implicit none
    character(len=*), intent(in) :: string
    character(len=len(string)) :: untabify
!#......................................................................
    integer :: i, j
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    untabify = string
    i = 1
    do
       j = index(string(i:), HT)
       if (j == 0) exit
       i = i+j-1
       untabify(i:i) = " "
       i = i+1
    enddo

  end function untabify

!#======================================================================

  pure function quote_string_aux(string, delim)

    implicit none
    character(len=*), intent(in) :: string
    character(len=2*len(string)+2) :: quote_string_aux
    character(len=1), intent(in) :: delim
!#......................................................................
    integer :: i, j
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    quote_string_aux = ""
    i = 1
    do
       j = index(string(i:), delim)
       if (j == 0) then
          quote_string_aux = trim(quote_string_aux) // string(i:)
          exit
       else
          quote_string_aux = trim(quote_string_aux) // string(i:i+j-1) // delim
          i = i+j
       endif
    enddo
    quote_string_aux = delim // trim(quote_string_aux) // delim

  end function quote_string_aux

!#======================================================================

  function quote_string1(string)

    implicit none
    character(len=*), intent(in) :: string
    character(len=len_trim(quote_string_aux(string, '"'))) :: quote_string1
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    quote_string1 = quote_string_aux(string, '"')

  end function quote_string1

!#======================================================================

  function quote_string2(string, delim)

    implicit none
    character(len=*), intent(in) :: string
    character(len=1), intent(in) :: delim
    character(len=len_trim(quote_string_aux(string, delim))) :: quote_string2
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    quote_string2 = quote_string_aux(string, delim)

  end function quote_string2

!#======================================================================

  pure function unquote_string_aux(string)

    implicit none
    character(len=*), intent(in) :: string
    character(len=long_string) :: unquote_string_aux
!#......................................................................
    character(len=1) :: delim
    integer :: i, j
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

!# Note: `unquote_string_aux` must be pure; otherwise, `unquote_string` cannot
!# be trimmed to its length without trailing spaces. Because  `unquote_string_aux`
!# must be pure, it cannot contain `write` or `stop` statements. These are moved in
!# `unquote_string` itself. To signal possible errors, the non-printable character
!# `NAK`, which the user is unlikely to type, is prepended to the error message
!# created in `unquote_string_aux`; `unquote_string` prints the error message and
!# stops if `unquote_string_aux` begins with `NAK`.

    if (string(1:1) == '"') then
       delim = '"'
    else if (string(1:1) == "'") then
       delim = "'"
    else
       delim = ""
    endif
    if (delim == "") then
       j = index(string, " ")
       if (j == 0) then
          unquote_string_aux = string
       else
          unquote_string_aux = string(:j-1)
       endif
    else
       unquote_string_aux = ""
       i = 2
       do
          j = index(string(i:), delim)
          if (j == 0) then !# No closing `delim` found.
             unquote_string_aux = NAK // "String `" // trim(string) // "` starts with `" // &
                  delim // "`, but there is no closing `" // delim // "`. Stopped."
             exit
          else
             if (string(i+j:i+j) == delim) then !# `delim` is doubled. Keep \
!# only one and continue.
                unquote_string_aux = trim(unquote_string_aux) // string(i:i+j-1)
                i = i+j+1
             else if (scan(string(i+j:i+j), " ,/") /= 0) then !# `delim` followed \
!# by a space character, `,` or `/`. OK.
                unquote_string_aux = trim(unquote_string_aux) // string(i:i+j-2)
                exit
             else
                unquote_string_aux = NAK // "Something lingering after the closing `" // &
                     delim // "`. Stopped."
                exit
             endif
          endif
       enddo
    endif

  end function unquote_string_aux

!#======================================================================

  function unquote_string(string)

    implicit none
    character(len=*), intent(in) :: string
    character(len=long_string) :: unquote_string
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

!# Note: `unquote_string` should not be used in a `write` statement because it
!# already contains a `write` statement.

    unquote_string = unquote_string_aux(string)
    if (unquote_string(1:1) == NAK) then
       write(*, "(a)") trim(unquote_string(2:))
       stop
    endif

  end function unquote_string

!#======================================================================

  function same_case_equal(string1, string2)

    implicit none

    character(len=*), intent(in) :: string1, string2
    logical :: same_case_equal
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (down_case(string1) == down_case(string2)) then
       same_case_equal = .true.
    else
       same_case_equal = .false.
    endif

  end function same_case_equal

!#======================================================================

  recursive subroutine find_closing_quote(line, pos, quote_character, quote_found)

    implicit none
    character(len=*), intent(in) :: line
    character, intent(in) :: quote_character
    integer, intent(inout) :: pos
    logical, intent(out) :: quote_found
!#......................................................................
    integer :: shift
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    shift = index(line(pos:), quote_character)
    if (shift == 0) then !# No closing quote found.
       quote_found = .false.
    else !# Closing quote found.
       pos = pos+shift-1
       quote_found = .true.
       if (pos < len_trim(line)) then
          if (line(pos+1:pos+1) == quote_character) then !# Two consecutive quotes.
             pos = pos+2
             quote_found = .false.
             call find_closing_quote(line, pos, quote_character, quote_found)
          endif
       endif
    endif

  end subroutine find_closing_quote

end module mod_strings
