!# 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_file_access

  use mod_strings, only : down_case
  use mod_dir_access, only : home_dir
  use mod_types, only : std_int
  implicit none
  private
  integer, parameter :: input_unit = 5, output_unit = 6, error_unit = 0 !# Usual values \
!# for inputs from the keyboard (stdin), outputs to the terminal (stdout) and error messages (stderr).
  integer, parameter :: unit_min = max(input_unit, output_unit, error_unit, &
       0_std_int) + 1, unit_max = 999

  type :: lk_lst_path
     character(len=132) :: val
     type(lk_lst_path), pointer :: parent => null()
     type(lk_lst_path), pointer :: child => null()
  end type lk_lst_path

  public :: open_file, get_unit, skip_comment_lines, skip_lines, close_file, &
       file_name_decomposition, path_file, extract_path, base_name, &
       file_name_components

contains

!#======================================================================
  
  subroutine open_file(unit, file, status, position, action, delim, form, &
       exist, iostat, skip)

!# `skip` is a boolean set to `.true.` (default) to skip comment lines (empty 
!# lines or lines beginning with "!") at the beginning of a file. 
!#
!# Caution if overwriting a file, even with `position = "rewind`: by defaut, 
!# writing will begin after initial comment lines!

    use mod_types, only : long_string
    implicit none
    integer, intent(out) :: unit !# ??? or `intent(inout)`?
    character(len=*), intent(in), optional :: file !# Optional for scratch \
!# files.
    character(len=*), optional, intent(in) :: action, status, position, &
         delim, form
    logical, optional, intent(in) :: skip
    logical, optional, intent(out) :: exist
    integer, optional, intent(out) :: iostat
!#......................................................................
    integer, parameter :: n_char = max( &
         len("read"), len("write"), len("readwrite"), &  !# `action` values.
         len("old"), len("new"), len("replace"), &       !# `status` values.
         len("scratch"), len("unknown"), &               !# Idem.
         len("rewind"), len("append"), len("asis"), &    !# `position` values.
         len("apostrophe"), len("quote"), len("none"), & !# `delim` values.
         len("formatted"), len("unformatted"))           !# `form` values.
    character(len=n_char) :: action_def, status_def, position_def, &
         delim_def, form_def
    character(len=n_char) :: action_eff, status_eff, position_eff, &
         delim_eff, form_eff
    logical :: skip_def, skip_eff
    integer :: ios
    logical :: exist_val
    character(len=long_string) :: file_tmp
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    status_def = "old"
    action_def = "read"
    position_def = "rewind"
    delim_def = "quote"
    form_def = "formatted"
    skip_def = .true.
    if (present(status)) then
       status_eff = down_case(status)
    else
       status_eff = status_def
    endif
    if (status_eff /= "old") action_def = "readwrite"
    if (status_eff == "replace") skip_def = .false.
    if (present(action)) then
       action_eff = down_case(action)
    else
       action_eff = action_def
    endif
    if (action_eff /= "read") position_def = "append"
    if (present(position)) then
       position_eff = down_case(position)
    else
       position_eff = position_def
    endif
!# Note. With `position="append"` and `skip=.false.`, the `endfile` record is 
!# the next record (Fortran 95 standard, rule 9.3.34.7).
!# If `skip=.true.`, the code tries to read something. The position may then
!# be before or after the `endfile` record. This depends on the compiler 
!# (ifort, gfortran) and maybe on the version of gfortran.
    if (position_eff == "append") skip_def = .false.

    if (present(delim)) then
       delim_eff = down_case(delim)
    else
       delim_eff = delim_def
    endif
    if (present(form)) then
       form_eff = down_case(form)
    else
       form_eff = form_def
    endif
    if (present(skip)) then
       skip_eff = skip
    else
       skip_eff = skip_def
    endif

    if (status_eff /= "scratch") then
       file_tmp = adjustl(file)
       if (file_tmp(1:1) == "~") file_tmp = home_dir // file_tmp(3:)
       inquire(file = file_tmp, exist = exist_val)
       if (present(exist)) then
          exist = exist_val
!# Note: Windows does not seem to distinguish between uppercase 
!# and lowercase letters for filenames.
          if (exist .and. status_eff == "new") then
             write(*,*) "Error opening file """ // trim(adjustl(file)) // &
                  """: an existing file cannot have status ""new"". Stopped."
             stop
          else if (.not.exist .and. status_eff == "old") then
             write(*,*) "Error opening file """ // trim(adjustl(file)) // &
                  """: a non-existing file cannot have status ""old"". Stopped."
             stop
          endif
       else !# `exist` absent: proceed smoothly.
          if (.not.exist_val .and. status_eff == "old") status_eff = "new"
       endif
    endif

    call get_unit(unit)
    if (form == "unformatted") then
       if (status_eff == "scratch") then
          open(unit = unit, action = action_eff, &
               status = status_eff, position = position_eff, form = form_eff, &
               iostat = ios)
       else
          open(unit = unit, file = file_tmp, action = action_eff, &
               status = status_eff, position = position_eff, form = form_eff, &
               iostat = ios)
       endif
    else
       if (status_eff == "scratch") then
          open(unit = unit, action = action_eff, &
               status = status_eff, position = position_eff, delim = delim_eff, &
               form = form_eff, iostat = ios)
       else
          open(unit = unit, file = file_tmp, action = action_eff, &
               status = status_eff, position = position_eff, delim = delim_eff, &
               form = form_eff, iostat = ios)
       endif
    endif

    if (present(iostat)) then
       iostat = ios
    else
       if (ios /= 0) then
          write(*,*) "Error opening file """ // trim(adjustl(file)) // &
               """. Stopped."
          stop
       endif
    endif
    if (skip_eff) call skip_comment_lines(unit)

  end subroutine open_file

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

  subroutine get_unit(unit)
    
    implicit none
    integer, intent(out) :: unit
!#......................................................................
    integer :: i
    logical :: opened
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    unit = -1
    do i = unit_min, unit_max
       if (any((/input_unit, output_unit, error_unit/) == i)) cycle !# Not needed, \
!# given the definition of `unit_min`.
       inquire(unit = i, opened = opened)
       if (.not. opened) then
          unit = i
          exit
       endif
    enddo
    if (unit == (-1)) then
       write(*,*) "Error: all the units are used. Stopped."
       stop
    endif
    
  end subroutine get_unit

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

  subroutine skip_comment_lines(unit)
    
    use mod_types
    implicit none
    integer, intent(in) :: unit
!#......................................................................
    character(len=long_string) :: string
    integer :: ios
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    do
       read(unit, "(a)", iostat = ios) string
       if (ios /= 0) exit
       string = adjustl(string)
       if (string == "" .or. string(1:1) == "!") then
          cycle
       else
          backspace(unit)
          exit
       endif
    enddo
    write(unit, iostat=ios)

!# If this subroutine reaches the end of the file, the position is *after* the 
!# end of file with gfortran-6 and later versions, so one must backspace once 
!# to write something else. To do this, one can move the `backspace(unit)` 
!# after the `enddo`.
!# With ifort and some earlier versions of gfortran, the position reached when 
!# reading up to the end of the file is *before* the end of file, so one must 
!# not backspace to write something else (current implementation). 
!# (See https://gcc.gnu.org/bugzilla/show_bug.cgi?id=52860 .)
!#
!# The empty "write" statement `write(unit, iostat=ios)` seems to work in all 
!# cases and avoids to move the `backspace(unit)`, depending on the compiler.

  end subroutine skip_comment_lines

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

  subroutine skip_lines(unit, n_lines)
    
    implicit none
    integer, intent(in) :: unit, n_lines
!#......................................................................
    integer :: i_line, ios
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    do i_line = 1, n_lines
       read(unit, "(a)", iostat = ios) 
       if (ios /= 0) then
          write(*, "(a,i0,a)") "Could skip only ", i_line-1, " lines. Stopped."
          stop
       endif
    enddo

  end subroutine skip_lines

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

  subroutine close_file(unit)

    implicit none
    integer, intent(inout) :: unit
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    
    close(unit)
    unit = -1

  end subroutine close_file

!#======================================================================
  
  subroutine file_name_decomposition(full_name, dir_name, stem, &
       extension, base_name, dir_sep, ext_sep, absolute_path)

!# `full_name` = `dir_name` + `base_name`.
!# `base_name` = `stem` + `extension`.
!# If not void, the last non blank character of `dir_name` is `dir_sep_eff` 
!# (`/` in Unix).
!# If not void, the first character of `extension` is `ext_sep_eff`
!# (`.` normally).

    use mod_dir_access, only : dir_sep_def => dir_sep
    implicit none
    character(len=*), intent(in) :: full_name    
    character(len=1), intent(in), optional :: dir_sep, ext_sep
    character(len=len(full_name)), intent(out), optional :: &
         dir_name, stem, extension, base_name
    logical, intent(out), optional :: absolute_path
!#......................................................................
!    character(len=1), parameter :: dir_sep_def = "/"
    character(len=1) :: dir_sep_eff
    character(len=1), parameter :: ext_sep_def = "."
    character(len=1) :: ext_sep_eff
    character(len=len(full_name)) :: dir_name_eff, stem_eff, &
         extension_eff, base_name_eff
    integer :: pos
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(dir_sep)) then
       dir_sep_eff = dir_sep
    else
       dir_sep_eff = dir_sep_def
    endif

    pos = index(full_name, dir_sep_eff, back = .true.)
    dir_name_eff = adjustl(full_name(:pos))
    base_name_eff = adjustl(full_name(pos+1:))

    if (present(ext_sep)) then
       ext_sep_eff = ext_sep
    else
       ext_sep_eff = ext_sep_def
    endif

    pos = index(base_name_eff, ext_sep_eff, back = .true.)
    if (pos > 1) then !# "> 1" and not "> 0", so that hidden files (beginning
!# with a dot) will not be considered as extension if there is no other dot.
       stem_eff = base_name_eff(:pos-1)
       extension_eff = base_name_eff(pos:)
    else
       stem_eff = base_name_eff
       extension_eff = ""
    endif
    if (present(dir_name)) dir_name = dir_name_eff
    if (present(stem)) stem = stem_eff
    if (present(extension)) extension = extension_eff
    if (present(base_name)) base_name = base_name_eff
    if (present(absolute_path)) then
       if (dir_name_eff(1:1) == dir_sep_eff .or. dir_name_eff(1:1) == "~") then
          absolute_path = .true.
       else
          absolute_path = .false.
       endif
    endif

  end subroutine file_name_decomposition

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

  function path_file(path, file_name, dir_sep)

    use mod_dir_access, only : dir_sep_def => dir_sep
    use mod_types
    implicit none
    character(len=*), intent(in) :: path, file_name
    character(len=1), optional :: dir_sep
    character(len=len_trim(path)+len_trim(file_name)) :: path_file
!#......................................................................
!    character(len=1), parameter :: dir_sep_def = "/"
    character(len=1) :: dir_sep_eff
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(dir_sep)) then
       dir_sep_eff = dir_sep
    else
       dir_sep_eff = dir_sep_def
    endif

    call file_name_components(file_name=file_name, path=path, &
         full_name=path_file, dir_sep=dir_sep_eff)

  end function path_file

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

  function extract_path(dir_name, file_name, dir_sep)

    use mod_dir_access, only : dir_sep_def => dir_sep
    use mod_types
    implicit none
    character(len=*), intent(in) :: dir_name, file_name
    character(len=1), intent(in), optional :: dir_sep
    character(len=len_trim(dir_name)+len_trim(file_name)) :: extract_path
!#......................................................................
!    character(len=1), parameter :: dir_sep_def = "/"
    character(len=1) :: dir_sep_eff, first_char
    integer :: pos
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(dir_sep)) then
       dir_sep_eff = dir_sep
    else
       dir_sep_eff = dir_sep_def
    endif

    pos = index(file_name, dir_sep_eff, back = .true.)
    if (pos > 0) then
       first_char = file_name(1:1)
       if (first_char == dir_sep_eff .or. first_char == "~") then !# Absolute \
!# path given by `file_name`. Discard `dir_name`.
          extract_path = file_name(:pos)
       else !# Relative path.
          extract_path = trim(dir_name) // file_name(:pos) !???
       endif
    else
       extract_path = dir_name
    endif

  end function extract_path

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

  function base_name(file_name, dir_sep)

    use mod_dir_access, only : dir_sep_def => dir_sep
    use mod_types
    implicit none
    character(len=*), intent(in) :: file_name
    character(len=1), intent(in), optional :: dir_sep
    character(len=len_trim(file_name)) :: base_name
!#......................................................................
!    character(len=1), parameter :: dir_sep_def = "/"
    character(len=1) :: dir_sep_eff
    integer :: pos
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(dir_sep)) then
       dir_sep_eff = dir_sep
    else
       dir_sep_eff = dir_sep_def
    endif

    pos = index(file_name, dir_sep_eff, back = .true.)
    base_name = file_name(pos+1:)

  end function base_name

!#======================================================================
  
  subroutine file_name_components(file_name, path, full_name, dir_name, stem, &
       extension, base_name, dir_sep, ext_sep)

!# `file_name` is the input file name. It may begin with a path, absolute 
!# or relative.

!# `path` is the path to file pointed to by `file_name`. This path may be
!# completed or modified by `file_name`. If present, the value of `path` 
!# should end with `dir_sep_eff`.

!# `full_name` = `dir_name` + `base_name`.
!# `base_name` = `stem` + `extension`.
!# If not void, the last non blank character of `dir_name` is `dir_sep_eff` 
!# (`/` in Unix).
!# If not void, the first character of `extension` is `ext_sep_eff`
!# (`.` normally).

    use mod_dir_access, only : dir_sep_def => dir_sep
    use mod_types
    implicit none
    character(len=*), intent(in), optional :: file_name
    character(len=*), intent(in), optional :: path
    character(len=1), intent(in), optional :: dir_sep, ext_sep
    character(len=*), intent(out), optional :: &
         full_name, dir_name
    character(len=*), intent(out), optional :: &
         stem, extension, base_name
!#......................................................................
!    character(len=1), parameter :: dir_sep_def = "/"
    character(len=1) :: dir_sep_eff
    character(len=1), parameter :: ext_sep_def = "."
    character(len=1) :: ext_sep_eff
    character(len=0), parameter :: path_def = "", file_name_def = ""
    character(len=long_string) :: dir_name_eff
    character(len=long_string) :: stem_eff, extension_eff, base_name_eff, &
         path_eff, file_name_eff
    character(len=1) :: first_char
    type(lk_lst_path), pointer :: head_node => null(), current_node, &
         parent_node
    integer :: pos, length, pos2
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    if (present(dir_sep)) then
       dir_sep_eff = dir_sep
    else
       dir_sep_eff = dir_sep_def
    endif

    if (present(path)) then
       path_eff = adjustl(path)
       length = len_trim(path_eff)
       if (path_eff(length:length) /= dir_sep_eff) & !# Add directory \
!# separator at the end if forgotten.
            path_eff(length+1:length+1) = dir_sep_eff
       if (path_eff(1:1) == "~") path_eff = home_dir // path_eff(3:)
    else
       path_eff = path_def
    endif

    if (present(file_name)) then
       file_name_eff = adjustl(file_name)
    else
       file_name_eff = file_name_def
    endif
    
    pos = index(file_name_eff, dir_sep_eff, back = .true.)
    if (pos > 0) then
       first_char = file_name_eff(1:1)
       if (first_char == dir_sep_eff .or. first_char == "~") then !# Absolute \
!# path given by `file_name`. Discard `path`.
          if (first_char == "~") then
             full_name = home_dir // file_name_eff(3:)
          else
             full_name = file_name_eff
          endif
       else !# Relative path.
          full_name = trim(path_eff) // file_name_eff !???
       endif
    else
       full_name = trim(path_eff) // file_name_eff
    endif

    do !# Replace `//` (`\\`) by `/` (`\`).
       pos = index(full_name, dir_sep_eff // dir_sep_eff)
       if (pos == 0) exit
       if (full_name(pos+1:) /= dir_sep_eff) then
          full_name = full_name(:pos) // full_name(pos+2:)
       else !# Nothing after `//` (`\\`). Considered in case \
!# `pos+2 > len(full_name)`.
          full_name = full_name(:pos)
       endif
    enddo
    
    call lk_lst_initialize_path(head_node, current_node)

    pos = index(full_name, dir_sep_eff)
    if (pos == 0) then
       current_node % val = full_name
    else
       current_node % val = full_name(:pos)
       do
          pos2 = index(full_name(pos+1:), dir_sep_eff)
          call lk_lst_new_node_path(current_node)
          if (pos2 == 0) then
             current_node % val = full_name(pos+1:)
             exit
          else
             pos2 = pos + pos2
             current_node % val = full_name(pos+1:pos2)
             pos = pos2
          endif
       enddo
    endif
!# Last node: add `/` at the end if the last node is `.` or `..`.
    if (current_node % val == ".") then
       current_node % val = "." // dir_sep_eff
    else if (current_node % val == "..") then
       current_node % val = ".." // dir_sep_eff       
    endif

    current_node => head_node
    do
       if (.not.associated(current_node)) exit
       current_node => current_node % child
    enddo

    current_node => head_node
    do 
       if (.not.associated(current_node)) exit

!# `current_node = ./`.
       if (current_node % val == "." // dir_sep_eff) then
          parent_node => current_node % parent
          current_node => current_node % child
          current_node % parent => parent_node
          if (associated(parent_node)) then
             parent_node % child => current_node
          else !# `head_node = ./`.
             head_node => current_node             
          endif

!# `current_node = ../`.
       else if (current_node % val == ".." // dir_sep_eff) then
          parent_node => current_node % parent
          if (associated(parent_node)) then
             if (parent_node % val == dir_sep_eff) then
                write(*,"(a)") "Impossible path. Stopped."
                stop
             else if (parent_node % val(1:1) == "~") then
!# Let the calling program resolve `~/../` when executed.
                current_node => current_node % child
             else if (parent_node % val /= ".." // dir_sep_eff) then
                parent_node => parent_node % parent
                current_node => current_node % child
                parent_node % child => current_node
                if (associated(current_node)) then
                   current_node % parent => parent_node
                endif
             else !# All parent nodes should be equal to `../`.
                current_node => current_node % child
             endif
          else !# `current_node` is `head_node`.
             current_node => current_node % child
          endif
          
       else
          current_node => current_node % child
       endif
    enddo

    full_name = ""
    current_node => head_node
    do 
       if (.not.associated(current_node)) exit
       full_name = trim(full_name) // trim(current_node % val)
       current_node => current_node % child
    enddo
    call lk_lst_destroy_path(head_node)

    pos = index(full_name, dir_sep_eff, back = .true.)
    dir_name_eff = adjustl(full_name(:pos))
    base_name_eff = adjustl(full_name(pos+1:))

    if (present(ext_sep)) then
       ext_sep_eff = ext_sep
    else
       ext_sep_eff = ext_sep_def
    endif

    pos = index(base_name_eff, ext_sep_eff, back = .true.)
    if (pos > 1) then !# "> 1" and not "> 0", so that hidden files (beginning
!# with a dot) will not be considered as extension if there is no other dot.
       stem_eff = base_name_eff(:pos-1)
       extension_eff = base_name_eff(pos:)
    else
       stem_eff = base_name_eff
       extension_eff = ""
    endif
    if (present(dir_name)) dir_name = dir_name_eff
    if (present(stem)) stem = stem_eff
    if (present(extension)) extension = extension_eff
    if (present(base_name)) base_name = base_name_eff

  end subroutine file_name_components

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

  subroutine lk_lst_destroy_path(head_node)

    implicit none
    type(lk_lst_path), pointer :: head_node
!#......................................................................
    type(lk_lst_path), pointer :: current_node, next_node
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

!# Delete linked list, if already existing.
    current_node => head_node
    do
       if (.not.associated(current_node)) exit
       next_node => current_node % child
       if (associated(next_node)) nullify(next_node % parent)
       deallocate(current_node)
       current_node => next_node
    enddo
    nullify(head_node)

  end subroutine lk_lst_destroy_path

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

  subroutine lk_lst_initialize_path(head_node, current_node)

    implicit none
    type(lk_lst_path), pointer :: head_node, current_node
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

!# Delete linked list, if already existing.
    call lk_lst_destroy_path(head_node)

!# Set the head of the linked list.
    allocate(head_node)
    nullify(head_node % parent)
    nullify(head_node % child)
    current_node => head_node
    
  end subroutine lk_lst_initialize_path

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

  subroutine lk_lst_new_node_path(current_node)

    implicit none
    type(lk_lst_path), pointer :: current_node
!#......................................................................
    type(lk_lst_path), pointer :: parent_node
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    allocate(current_node % child)
    parent_node => current_node
    current_node => current_node % child
    current_node % parent => parent_node
    nullify(current_node % child)

  end subroutine lk_lst_new_node_path

end module mod_file_access
