!> This module contains procedures that interact with the programming environment.
!!
!! * [get_os_type] -- Determine the OS type
!! * [get_env] -- return the value of an environment variable
module fpm_environment
    use,intrinsic :: iso_fortran_env, only : stdin=>input_unit,   &
                                           & stdout=>output_unit, &
                                           & stderr=>error_unit
    use,intrinsic :: iso_c_binding, only: c_char,c_int,c_null_char
    use fpm_error, only : fpm_stop
    use fpm_strings, only : lower
    implicit none
    private
    public :: get_os_type
    public :: match_os_type
    public :: validate_os_name
    public :: os_is_unix
    public :: get_env
    public :: set_env
    public :: delete_env
    public :: get_command_arguments_quoted
    public :: separator
    public :: library_filename
    
                        public :: OS_NAME
    integer, parameter, public :: OS_ALL     = -1   ! "all" flag for profile support
    integer, parameter, public :: OS_UNKNOWN = 0
    integer, parameter, public :: OS_LINUX   = 1
    integer, parameter, public :: OS_MACOS   = 2
    integer, parameter, public :: OS_WINDOWS = 3
    integer, parameter, public :: OS_CYGWIN  = 4
    integer, parameter, public :: OS_SOLARIS = 5
    integer, parameter, public :: OS_FREEBSD = 6
    integer, parameter, public :: OS_OPENBSD = 7
contains

    !> Utility function: return library filename
    pure function library_filename(package_name, shared, import, target_os) result(name)
        character(*), intent(in) :: package_name    
        !> Whether it's a shared library
        logical, intent(in) :: shared       
        !> Whether it's for linking (import library) or actual library
        logical, intent(in) :: import       
        !> Build target OS: one of OS_WINDOWS, OS_MACOS, ...
        integer, intent(in) :: target_os        

        character(len=:), allocatable :: name

        if (shared) then
            select case (target_os)
            case (OS_WINDOWS)
                if (import) then
                    ! Linking requires the import library
                    name = 'lib' // package_name // '.lib'
                else
                    ! The actual shared object is a DLL
                    name = 'lib' // package_name // '.dll'
                end if
            case (OS_MACOS)
                name = 'lib' // package_name // '.dylib'
            case default
                name = 'lib' // package_name // '.so'
            end select
        else
            ! Static library (same for all platforms)
            name = 'lib' // package_name // '.a'
        end if

    end function library_filename

    !> Return string describing the OS type flag
    pure function OS_NAME(os)
        integer, intent(in) :: os
        character(len=:), allocatable :: OS_NAME

        select case (os)
            case (OS_LINUX);   OS_NAME =  "Linux"
            case (OS_MACOS);   OS_NAME =  "macOS"
            case (OS_WINDOWS); OS_NAME =  "Windows"
            case (OS_CYGWIN);  OS_NAME =  "Cygwin"
            case (OS_SOLARIS); OS_NAME =  "Solaris"
            case (OS_FREEBSD); OS_NAME =  "FreeBSD"
            case (OS_OPENBSD); OS_NAME =  "OpenBSD"
            case (OS_UNKNOWN); OS_NAME =  "Unknown"
            case (OS_ALL)    ; OS_NAME =  "all"
            case default     ; OS_NAME =  "UNKNOWN"
        end select
    end function OS_NAME

    !> Match os_name to os_type enum (similar to profiles.f90)
    integer function match_os_type(os_name) result(os_type)
        character(len=*), intent(in) :: os_name
        
        select case (lower(os_name))
            case ("linux");   os_type = OS_LINUX
            case ("macos");   os_type = OS_MACOS
            case ("windows"); os_type = OS_WINDOWS
            case ("cygwin");  os_type = OS_CYGWIN
            case ("solaris"); os_type = OS_SOLARIS
            case ("freebsd"); os_type = OS_FREEBSD
            case ("openbsd"); os_type = OS_OPENBSD
            case ("all");     os_type = OS_ALL
            case default;     os_type = OS_UNKNOWN
        end select
    end function match_os_type

    !> Check if os_name is a valid name of a supported OS
    pure elemental subroutine validate_os_name(os_name, is_valid)

       !> Name of an operating system
       character(len=*), intent(in) :: os_name

       !> Boolean value of whether os_name is valid or not
       logical, intent(out) :: is_valid

       select case (lower(os_name))
         case ("linux", "macos", "windows", "cygwin", "solaris", "freebsd", &
                         & "openbsd", "all")
           is_valid = .true.
         case default
           is_valid = .false.
       end select

    end subroutine validate_os_name

    !> Determine the OS type
    integer function get_os_type() result(r)
        !!
        !! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN,
        !! OS_SOLARIS, OS_FREEBSD, OS_OPENBSD.
        !!
        !! At first, the environment variable `OS` is checked, which is usually
        !! found on Windows. Then, `OSTYPE` is read in and compared with common
        !! names. If this fails too, check the existence of files that can be
        !! found on specific system types only.
        !!
        !! Returns OS_UNKNOWN if the operating system cannot be determined.
        character(len=255) :: val
        integer            :: length, rc
        logical            :: file_exists
        logical, save      :: first_run = .true.
        integer, save      :: ret = OS_UNKNOWN
        !$omp threadprivate(ret, first_run)

        if (.not. first_run) then
            r = ret
            return
        end if

        first_run = .false.
        r = OS_UNKNOWN

        ! Check environment variable `OSTYPE`.
        call get_environment_variable('OSTYPE', val, length, rc)

        if (rc == 0 .and. length > 0) then
            ! Linux
            if (index(val, 'linux') > 0) then
                r = OS_LINUX
                ret = r
                return
            end if

            ! macOS
            if (index(val, 'darwin') > 0) then
                r = OS_MACOS
                ret = r
                return
            end if

            ! Windows, MSYS, MinGW, Git Bash
            if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then
                r = OS_WINDOWS
                ret = r
                return
            end if

            ! Cygwin
            if (index(val, 'cygwin') > 0) then
                r = OS_CYGWIN
                ret = r
                return
            end if

            ! Solaris, OpenIndiana, ...
            if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then
                r = OS_SOLARIS
                ret = r
                return
            end if

            ! FreeBSD
            if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then
                r = OS_FREEBSD
                ret = r
                return
            end if

            ! OpenBSD
            if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then
                r = OS_OPENBSD
                ret = r
                return
            end if
        end if

        ! Check environment variable `OS`.
        call get_environment_variable('OS', val, length, rc)

        if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then
            r = OS_WINDOWS
            ret = r
            return
        end if

        ! Linux
        inquire (file='/etc/os-release', exist=file_exists)

        if (file_exists) then
            r = OS_LINUX
            ret = r
            return
        end if

        ! macOS
        inquire (file='/usr/bin/sw_vers', exist=file_exists)

        if (file_exists) then
            r = OS_MACOS
            ret = r
            return
        end if

        ! FreeBSD
        inquire (file='/bin/freebsd-version', exist=file_exists)

        if (file_exists) then
            r = OS_FREEBSD
            ret = r
            return
        end if
    end function get_os_type

    !> Compare the output of [[get_os_type]] or the optional
    !! passed INTEGER value to the value for OS_WINDOWS
    !! and return .TRUE. if they match and .FALSE. otherwise
    logical function os_is_unix(os)
        integer, intent(in), optional :: os
        integer :: build_os
        if (present(os)) then
            build_os = os
        else
            build_os = get_os_type()
        end if
        os_is_unix = build_os /= OS_WINDOWS
    end function os_is_unix

    !> get named environment variable value. It it is blank or
    !! not set return the optional default value
    function get_env(NAME,DEFAULT) result(VALUE)
    implicit none
    !> name of environment variable to get the value of
    character(len=*),intent(in)          :: NAME
    !> default value to return if the requested value is undefined or blank
    character(len=*),intent(in),optional :: DEFAULT
    !> the returned value
    character(len=:),allocatable         :: VALUE
    integer                              :: howbig
    integer                              :: stat
    integer                              :: length
        ! get length required to hold value
        length=0
        if(NAME/='')then
           call get_environment_variable(NAME, length=howbig,status=stat,trim_name=.true.)
           select case (stat)
           case (1)
               !*!print *, NAME, " is not defined in the environment. Strange..."
               VALUE=''
           case (2)
               !*!print *, "This processor doesn't support environment variables. Boooh!"
               VALUE=''
           case default
               ! make string to hold value of sufficient size
               allocate(character(len=max(howbig,1)) :: VALUE)
               ! get value
               call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.)
               if(stat/=0)VALUE=''
           end select
        else
           VALUE=''
        endif
        if(VALUE==''.and.present(DEFAULT))VALUE=DEFAULT
     end function get_env

    function get_command_arguments_quoted() result(args)
    character(len=:),allocatable :: args
    character(len=:),allocatable :: arg
    character(len=1)             :: quote
    integer                      :: ilength, istatus, i
    ilength=0
    args=''
        quote=merge('"',"'",separator()=='\')
        do i=2,command_argument_count() ! look at all arguments after subcommand
            call get_command_argument(number=i,length=ilength,status=istatus)
            if(istatus /= 0) then
                write(stderr,'(*(g0,1x))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i
                exit
            else
                if(allocated(arg))deallocate(arg)
                allocate(character(len=ilength) :: arg)
                call get_command_argument(number=i,value=arg,length=ilength,status=istatus)
                if(istatus /= 0) then
                    write(stderr,'(*(g0,1x))')'<ERROR>*get_command_arguments_stack* error obtaining argument ',i
                    exit
                elseif(ilength>0)then
                    if(index(arg//' ','-')/=1)then
                        args=args//quote//arg//quote//' '
                    elseif(index(arg,' ')/=0)then
                        args=args//quote//arg//quote//' '
                    else
                        args=args//arg//' '
                    endif
                else
                    args=args//repeat(quote,2)//' '
                endif
             endif
         enddo
    end function get_command_arguments_quoted

function separator() result(sep)
!>
!!##NAME
!!    separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character
!!    (LICENSE:PD)
!!
!!##SYNOPSIS
!!
!!    function separator() result(sep)
!!
!!     character(len=1) :: sep
!!
!!##DESCRIPTION
!!    First using the name the program was invoked with, then the name
!!    returned by an INQUIRE(3f) of that name, then ".\NAME" and "./NAME"
!!    try to determine the separator character used to separate directory
!!    names from file basenames.
!!
!!    If a slash or backslash is not found in the name, the environment
!!    variable PATH is examined first for a backslash, then a slash.
!!
!!    Can be very system dependent. If the queries fail the default returned
!!    is "/".
!!
!!##EXAMPLE
!!
!!   sample usage
!!
!!    program demo_separator
!!    use M_io, only : separator
!!    implicit none
!!       write(*,*)'separator=',separator()
!!    end program demo_separator

! use the pathname returned as arg0 to determine pathname separator
implicit none
character(len=:),allocatable :: arg0
integer                      :: arg0_length
integer                      :: istat
logical                      :: existing
character(len=1)             :: sep
!*ifort_bug*!character(len=1),save        :: sep_cache=' '
character(len=4096)          :: name
character(len=:),allocatable :: fname

   !*ifort_bug*!   if(sep_cache/=' ')then  ! use cached value. NOTE:  A parallel code might theoretically use multiple OS
   !*ifort_bug*!      sep=sep_cache
   !*ifort_bug*!      return
   !*ifort_bug*!   endif

   arg0_length=0
   name=' '
   call get_command_argument(0,length=arg0_length,status=istat)
   if(allocated(arg0))deallocate(arg0)
   allocate(character(len=arg0_length) :: arg0)
   call get_command_argument(0,arg0,status=istat)
   ! check argument name
   if(index(arg0,'\')/=0)then
      sep='\'
   elseif(index(arg0,'/')/=0)then
      sep='/'
   else
      ! try name returned by INQUIRE(3f)
      existing=.false.
      name=' '
      inquire(file=arg0,iostat=istat,exist=existing,name=name)
      if(index(name,'\')/=0)then
         sep='\'
      elseif(index(name,'/')/=0)then
         sep='/'
      else
         ! well, try some common syntax and assume in current directory
         fname='.\'//arg0
         inquire(file=fname,iostat=istat,exist=existing)
         if(existing)then
            sep='\'
         else
            fname='./'//arg0
            inquire(file=fname,iostat=istat,exist=existing)
            if(existing)then
               sep='/'
            else ! check environment variable PATH
               sep=merge('\','/',index(get_env('PATH'),'\')/=0)
               !*!write(*,*)'<WARNING>unknown system directory path separator'
            endif
         endif
      endif
   endif
   !*ifort_bug*!sep_cache=sep
end function separator

!> Set an environment variable for the current environment using the C standard library
logical function set_env(name,value,overwrite)

   !> Variable name
   character(*), intent(in) :: name
   
   !> Variable value
   character(*), intent(in) :: value
   
   !> Should a former value be overwritten? default = .true.
   logical, optional, intent(in) :: overwrite
   
   ! Local variables
   logical :: can_overwrite
   integer(c_int) :: cover,cerr
   character(kind=c_char,len=1), allocatable :: c_value(:),c_name(:)
   
   interface
      integer(c_int) function c_setenv(envname, envval, overwrite) &
                     bind(C,name="c_setenv")
         import c_int, c_char
         implicit none
         !> Pointer to the name string
         character(kind=c_char,len=1), intent(in) :: envname(*)
         !> Pointer to the value string 
         character(kind=c_char,len=1), intent(in) :: envval(*)
         !> Overwrite option
         integer(c_int), intent(in), value :: overwrite
      end function c_setenv 
   end interface
   
   !> Overwrite setting
   cerr = 0_c_int
   can_overwrite = .true.
   if (present(overwrite)) can_overwrite = overwrite
   cover = merge(1_c_int,0_c_int,can_overwrite)
   
   !> C strings
   call f2cs(name,c_name)
   call f2cs(value,c_value)
   
   !> Call setenv
#ifndef FPM_BOOTSTRAP   
   cerr = c_setenv(c_name,c_value,cover)
#endif
   set_env = cerr==0_c_int
   
end function set_env

!> Deletes an environment variable for the current environment using the C standard library
!> Returns an error if the variable did not exist in the first place
logical function delete_env(name) result(success)

   !> Variable name
   character(*), intent(in) :: name
   
   ! Local variables
   integer(c_int) :: cerr
   character(kind=c_char,len=1), allocatable :: c_name(:)
   
   interface
      integer(c_int) function c_unsetenv(envname) bind(C,name="c_unsetenv")
         import c_int, c_char
         implicit none
         !> Pointer to the name string
         character(kind=c_char,len=1), intent(in) :: envname(*)
      end function c_unsetenv      
   end interface
   
   !> C strings
   call f2cs(name,c_name)
   
   !> Call setenv
#ifndef FPM_BOOTSTRAP   
   cerr = c_unsetenv(c_name)
#endif
   success = cerr==0_c_int
   
end function delete_env

!> Fortran to C allocatable string
pure subroutine f2cs(f,c)
  use iso_c_binding, only: c_char,c_null_char
  character(*), intent(in) :: f
  character(len=1,kind=c_char), allocatable, intent(out) :: c(:)
  
  integer :: lf,i
  
  lf = len(f)
  allocate(c(lf+1))
  c(lf+1) = c_null_char 
  forall(i=1:lf) c(i) = f(i:i)
  
end subroutine f2cs 

end module fpm_environment
