stdlib_io.fypp

#:include "common.fypp"

#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES

module stdlib_io
  !! Provides a support for file handling
  !! ([Specification](../page/specs/stdlib_io.html))

  use, intrinsic :: iso_fortran_env, only : input_unit
  use stdlib_kinds, only: sp, dp, xdp, qp, &
      int8, int16, int32, int64
  use stdlib_error, only: error_stop, state_type, STDLIB_IO_ERROR
  use stdlib_optval, only: optval
  use stdlib_ascii, only: is_blank
  use stdlib_string_type, only : string_type, assignment(=), move
  implicit none
  private
  ! Public API
  public :: loadtxt, savetxt, open, get_line, get_file

  !! version: experimental 
  !!
  !! Reads a whole ASCII file and loads its contents into a string variable. 
  !! ([Specification](../page/specs/stdlib_io.html#get-file-read-a-whole-ascii-file-into-a-character-or-a-string-variable))
  !! 
  !!### Summary 
  !! Subroutine interface for reading the content of a file into a string.
  !!
  !!### Description
  !! 
  !! This subroutine reads the entirety of a specified ASCII file and returns it as a string. The optional 
  !! `err` argument allows for handling errors through the library's `state_type` class. 
  !! An optional `logical` flag can be passed to delete the file after reading.  
  !! 
  !!@note Handles errors using the library's `state_type` error-handling class. If not provided, 
  !! exceptions will trigger an `error stop`. 
  !!         
  interface get_file
    module procedure :: get_file_char
    module procedure :: get_file_string
  end interface get_file

  ! Private API that is exposed so that we can test it in tests
  public :: parse_mode

  !> Version: experimental
  !>
  !> Format strings with edit descriptors for each type and kind
  !> ([Specification](../page/specs/stdlib_io.html))
  character(*), parameter :: &
    !> Format string for integers
    FMT_INT = '(i0)', &
    !> Format string for single precision real numbers
    FMT_REAL_SP = '(es15.8e2)', &
    !> Format string for souble precision real numbers
    FMT_REAL_DP = '(es24.16e3)', &
    !> Format string for extended double precision real numbers
    FMT_REAL_XDP = '(es26.18e3)', &
    !> Format string for quadruple precision real numbers
    FMT_REAL_QP = '(es44.35e4)', &
    !> Format string for single precision complex numbers
    FMT_COMPLEX_SP = '(es15.08e2,1x,es15.08e2)', &
    !> Format string for double precision complex numbers
    FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', &
    !> Format string for extended double precision complex numbers
    FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', &
    !> Format string for quadruple precision complex numbers
    FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)'
  !> Default delimiter for loadtxt, savetxt and number_of_columns
  character(len=1), parameter :: delimiter_default = " "

  public :: FMT_INT, FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_XDP, FMT_REAL_QP
  public :: FMT_COMPLEX_SP, FMT_COMPLEX_DP, FMT_COMPLEX_XDP, FMT_COMPLEX_QP

  !> Version: experimental
  !>
  !> Read a whole line from a formatted unit into a string variable
  interface get_line
    module procedure :: get_line_char
    module procedure :: get_line_string
    module procedure :: get_line_input_char
    module procedure :: get_line_input_string
  end interface get_line

  interface loadtxt
    !! version: experimental
    !!
    !! Loads a 2D array from a text file
    !! ([Specification](../page/specs/stdlib_io.html#description))
    #:for k1, t1 in KINDS_TYPES
      module procedure loadtxt_${t1[0]}$${k1}$
    #:endfor
  end interface loadtxt

  interface savetxt
    !! version: experimental
    !!
    !! Saves a 2D array into a text file
    !! ([Specification](../page/specs/stdlib_io.html#description_2))
    #:for k1, t1 in KINDS_TYPES
      module procedure savetxt_${t1[0]}$${k1}$
    #:endfor
  end interface

contains

  #:for k1, t1 in KINDS_TYPES
    subroutine  loadtxt_${t1[0]}$${k1}$(filename, d, skiprows, max_rows, fmt, delimiter)
      !! version: experimental
      !!
      !! Loads a 2D array from a text file.
      !!
      !! Arguments
      !! ---------
      !!
      !! Filename to load the array from
      character(len=*), intent(in) :: filename
      !! The array 'd' will be automatically allocated with the correct dimensions
      ${t1}$, allocatable, intent(out) :: d(:,:)
      !! Skip the first `skiprows` lines. If skipping more rows than present, a 0-sized array will be returned. The default is 0.
      integer, intent(in), optional :: skiprows
      !! Read `max_rows` lines of content after `skiprows` lines.
      !! A negative value results in reading all lines.
      !! A value of zero results in no lines to be read.
      !! The default value is -1.
      integer, intent(in), optional :: max_rows
      character(len=*), intent(in), optional :: fmt
      character(len=1), intent(in), optional :: delimiter
      character(len=:), allocatable :: fmt_
      character(len=1) :: delimiter_
      !!
      !! Example
      !! -------
      !!
      !!```fortran
      !! ${t1}$, allocatable :: data(:, :)
      !! call loadtxt("log.txt", data)  ! 'data' will be automatically allocated
      !!```
      !!
      !! Where 'log.txt' contains for example::
      !!
      !!     1 2 3
      !!     2 4 6
      !!     8 9 10
      !!     11 12 13
      !!     ...
      !!
      integer :: s
      integer :: nrow, ncol, i, j, ios, skiprows_, max_rows_, istart, iend
      character(len=:), allocatable :: line, iomsg_
      character(len=1024) :: iomsg, msgout

      skiprows_ = max(optval(skiprows, 0), 0)
      max_rows_ = optval(max_rows, -1)
      delimiter_ = optval(delimiter, delimiter_default)

      s = open(filename)

      ! determine number or rows
      nrow = number_of_rows(s)
      skiprows_ = min(skiprows_, nrow)
      if ( max_rows_ < 0 .or. max_rows_ > (nrow - skiprows_) ) max_rows_ = nrow - skiprows_

      ! determine number of columns
      ncol = 0
      if ( skiprows_ < nrow ) ncol = number_of_columns(s, skiprows=skiprows_, delimiter=delimiter_)
      #:if 'complex' in t1
      ncol = ncol / 2
      #:endif

      allocate(d(max_rows_, ncol))
      if (max_rows_ == 0 .or. ncol == 0) return

      do i = 1, skiprows_
        read(s, *, iostat=ios, iomsg=iomsg)
        
        if (ios/=0) then 
           write(msgout,1) trim(iomsg),i,trim(filename) 
           1 format('loadtxt: error <',a,'> skipping line ',i0,' of ',a,'.')
           call error_stop(msg=trim(msgout))
        end if
        
      end do
      
      ! Default to format used for savetxt if fmt not specified.
      #:if 'real' in t1
      fmt_ = optval(fmt, "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",:,1x))")
      #:elif 'complex' in t1
      fmt_ = optval(fmt, "(*"//FMT_COMPLEX_${k1}$(1:len(FMT_COMPLEX_${k1}$)-1)//",:,1x))")
      #:else
      fmt_ = optval(fmt, "*")
      #:endif      

      if ( fmt_ == '*' ) then
        ! Use list directed read if user has specified fmt='*'
        if (is_blank(delimiter_) .or. delimiter_ == ",") then
          do i = 1, max_rows_
            read (s,*,iostat=ios,iomsg=iomsg) d(i, :)
            
            if (ios/=0) then 
              write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
              call error_stop(msg=trim(msgout))
            end if          
            
          enddo
        ! Otherwise read each value separately
        else
          do i = 1, max_rows_
            call get_line(s, line, ios, iomsg_)
            if (ios/=0) then 
               write(msgout,2) trim(iomsg_),size(d,2),i,trim(filename)
               call error_stop(msg=trim(msgout))
            end if
  
            istart = 0
            do j = 1, ncol - 1
              iend = index(line(istart+1:), delimiter_)
              read (line(istart+1:istart+iend-1),*,iostat=ios,iomsg=iomsg) d(i, j)
              if (ios/=0) then 
                 write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
                 call error_stop(msg=trim(msgout))
              end if
              istart = istart + iend
            end do
  
            read (line(istart+1:),*,iostat=ios,iomsg=iomsg) d(i, ncol)
            if (ios/=0) then 
               write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
               call error_stop(msg=trim(msgout))
            end if          
            
          enddo
        end if
      else
        ! Otherwise pass default or user specified fmt string.
        do i = 1, max_rows_
          read (s,fmt_,iostat=ios,iomsg=iomsg) d(i, :)
          
          if (ios/=0) then 
             write(msgout,2) trim(iomsg),size(d,2),i,trim(filename)
             call error_stop(msg=trim(msgout))
          end if             
          
        enddo
      endif

      close(s)
      
      2 format('loadtxt: error <',a,'> reading ',i0,' values from line ',i0,' of ',a,'.')

    end subroutine loadtxt_${t1[0]}$${k1}$
  #:endfor


  #:for k1, t1 in KINDS_TYPES
    subroutine savetxt_${t1[0]}$${k1}$(filename, d, delimiter)
      !! version: experimental
      !!
      !! Saves a 2D array into a text file.
      !!
      !! Arguments
      !! ---------
      !!
      character(len=*), intent(in) :: filename  ! File to save the array to
      ${t1}$, intent(in) :: d(:,:)           ! The 2D array to save
      character(len=1), intent(in), optional :: delimiter  ! Column delimiter. Default is a space.
      !!
      !! Example
      !! -------
      !!
      !!```fortran
      !! ${t1}$ :: data(3, 2)
      !! call savetxt("log.txt", data)
      !!```
      !!
      integer :: s, i, ios
      character(len=1) :: delimiter_
      character(len=3) :: delim_str
      character(len=:), allocatable :: fmt_
      character(len=1024) :: iomsg, msgout

      delimiter_ = optval(delimiter, delimiter_default)
      delim_str = "'"//delimiter_//"'"
      #:if 'real' in t1
        fmt_ = "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",:,"//delim_str//"))"
      #:elif 'complex' in t1
        fmt_ = "(*"//FMT_COMPLEX_${k1}$(1:11)//delim_str//FMT_COMPLEX_${k1}$(14:23)//",:,"//delim_str//"))"
      #:elif 'integer' in t1
        fmt_ = "(*"//FMT_INT(1:len(FMT_INT)-1)//",:,"//delim_str//"))"
      #:endif

      s = open(filename, "w")
      do i = 1, size(d, 1)
        #:if 'real' in t1 or 'complex' in t1 or 'integer' in t1
          write(s, fmt_, &
        #:else
          write(s, *, &
        #:endif
                iostat=ios,iomsg=iomsg) d(i, :)
        
        if (ios/=0) then 
           write(msgout,1) trim(iomsg),size(d,2),i,trim(filename) 
           call error_stop(msg=trim(msgout))
        end if           
        
      end do
      close(s)
      
      1 format('savetxt: error <',a,'> writing ',i0,' values to line ',i0,' of ',a,'.')
      
    end subroutine savetxt_${t1[0]}$${k1}$
  #:endfor


  integer function number_of_columns(s, skiprows, delimiter)
    !! version: experimental
    !!
    !! determine number of columns
    integer,intent(in) :: s
    integer, intent(in), optional :: skiprows
    character(len=1), intent(in), optional :: delimiter

    integer :: ios, skiprows_, i
    character :: c
    character(len=:), allocatable :: line
    character(len=1) :: delimiter_
    logical :: last_delim

    skiprows_ = optval(skiprows, 0)
    delimiter_ = optval(delimiter, delimiter_default)

    rewind(s)

    do i = 1, skiprows_
      read(s, *)
    end do
    number_of_columns = 0
    
    ! Read first non-skipped line as a whole
    call get_line(s, line, ios)
    if (ios/=0 .or. .not.allocated(line)) return

    last_delim = .true.
    if (delimiter_ == delimiter_default) then
      do i = 1,len(line)
        c = line(i:i)
        if (last_delim .and. .not. is_blank(c)) number_of_columns = number_of_columns + 1
        last_delim = is_blank(c)
      end do
    else
      do i = 1,len(line)
        if (line(i:i) == delimiter_) number_of_columns = number_of_columns + 1
      end do
      if (number_of_columns == 0) then
        if (len_trim(line) /= 0) number_of_columns = 1
      else
        number_of_columns = number_of_columns + 1
      end if
    end if
    rewind(s)

  end function number_of_columns


  integer function number_of_rows(s) result(nrows)
    !! version: experimental
    !!
    !! Determine the number or rows in a file
    integer, intent(in)::s
    integer :: ios

    rewind(s)
    nrows = 0
    do
      read(s, *, iostat=ios)
      if (ios /= 0) exit
      nrows = nrows + 1
    end do

    rewind(s)

  end function number_of_rows


  integer function open(filename, mode, iostat) result(u)
    !! version: experimental
    !!
    !! Opens a file
    !! ([Specification](../page/specs/stdlib_io.html#description_1))
    !!
    !!##### Behavior
    !!
    !!
    !! To open a file to read:
    !!
    !!```fortran
    !! u = open("somefile.txt")        ! The default `mode` is "rt"
    !! u = open("somefile.txt", "r")
    !!```
    !!
    !! To open a file to write:
    !!
    !!```fortran
    !! u = open("somefile.txt", "w")
    !!```
    !!
    !! To append to the end of the file if it exists:
    !!
    !!```fortran
    !! u = open("somefile.txt", "a")
    !!```

    character(*), intent(in) :: filename
    character(*), intent(in), optional :: mode
    integer, intent(out), optional :: iostat

    character(3) :: mode_
    character(:),allocatable :: action_, position_, status_, access_, form_


    mode_ = parse_mode(optval(mode, ""))

    select case (mode_(1:2))
    case('r')
      action_='read'
      position_='asis'
      status_='old'
    case('w')
      action_='write'
      position_='asis'
      status_='replace'
    case('a')
      action_='write'
      position_='append'
      status_='old'
    case('x')
      action_='write'
      position_='asis'
      status_='new'
    case('r+')
      action_='readwrite'
      position_='asis'
      status_='old'
    case('w+')
      action_='readwrite'
      position_='asis'
      status_='replace'
    case('a+')
      action_='readwrite'
      position_='append'
      status_='old'
    case('x+')
      action_='readwrite'
      position_='asis'
      status_='new'
    case default
      call error_stop("Unsupported mode: "//mode_(1:2))
    end select

    select case (mode_(3:3))
    case('t')
      form_='formatted'
      access_='sequential'
    case('b')
      form_='unformatted'
      access_ = 'stream'
    case default
      call error_stop("Unsupported mode: "//mode_(3:3))
    end select

    if (present(iostat)) then
      open(newunit=u, file=filename, &
          action = action_, position = position_, status = status_, &
          access = access_, form = form_, &
          iostat = iostat)
    else
      open(newunit=u, file=filename, &
          action = action_, position = position_, status = status_, &
          access = access_, form = form_)
    end if

  end function open

  character(3) function parse_mode(mode) result(mode_)
    character(*), intent(in) :: mode

    integer :: i
    character(:),allocatable :: a
    logical :: lfirst(3)

    mode_ = 'r t'

    if (len_trim(mode) == 0) return
    a=trim(adjustl(mode))

    lfirst = .true.
    do i=1,len(a)
      if (lfirst(1) &
          .and. (a(i:i) == 'r' .or. a(i:i) == 'w' .or. a(i:i) == 'a' .or. a(i:i) == 'x') &
          ) then
        mode_(1:1) = a(i:i)
        lfirst(1)=.false.
      else if (lfirst(2) .and. a(i:i) == '+') then
        mode_(2:2) = a(i:i)
        lfirst(2)=.false.
      else if (lfirst(3) .and. (a(i:i) == 't' .or. a(i:i) == 'b')) then
        mode_(3:3) = a(i:i)
        lfirst(3)=.false.
      else if (a(i:i) == ' ') then
        cycle
      else if(any(.not.lfirst)) then
        call error_stop("Wrong mode: "//trim(a))
      else
        call error_stop("Wrong character: "//a(i:i))
      endif
    end do

  end function parse_mode

  !> Version: experimental
  !>
  !> Read a whole line from a formatted unit into a deferred length character variable
  subroutine get_line_char(unit, line, iostat, iomsg)
    !> Formatted IO unit
    integer, intent(in) :: unit
    !> Line to read
    character(len=:), allocatable, intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    integer, parameter :: bufsize = 4096
    character(len=bufsize) :: buffer, msg
    integer :: chunk, stat
    logical :: opened

    if (unit /= -1) then
      inquire(unit=unit, opened=opened)
    else
      opened = .false.
    end if

    if (opened) then
      open(unit=unit, pad="yes", iostat=stat, iomsg=msg)
    else
      stat = 1
      msg = "Unit is not connected"
    end if

    line = ""
    do while (stat == 0)
      read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=chunk) buffer
      if (stat > 0) exit
      line = line // buffer(:chunk)
    end do
    if (is_iostat_eor(stat)) stat = 0

    if (stat /= 0 .and. present(iomsg)) iomsg = trim(msg)
    if (present(iostat)) then
      iostat = stat
    else if (stat /= 0) then
      call error_stop(trim(msg))
    end if
  end subroutine get_line_char

  !> Version: experimental
  !>
  !> Read a whole line from a formatted unit into a string variable
  subroutine get_line_string(unit, line, iostat, iomsg)
    !> Formatted IO unit
    integer, intent(in) :: unit
    !> Line to read
    type(string_type), intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    character(len=:), allocatable :: buffer

    call get_line(unit, buffer, iostat, iomsg)
    line = string_type(buffer)
  end subroutine get_line_string

  !> Version: experimental
  !>
  !> Read a whole line from the standard input into a deferred length character variable
  subroutine get_line_input_char(line, iostat, iomsg)
    !> Line to read
    character(len=:), allocatable, intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    call get_line(input_unit, line, iostat, iomsg)
  end subroutine get_line_input_char

  !> Version: experimental
  !>
  !> Read a whole line from the standard input into a string variable
  subroutine get_line_input_string(line, iostat, iomsg)
    !> Line to read
    type(string_type), intent(out) :: line
    !> Status of operation
    integer, intent(out), optional :: iostat
    !> Error message
    character(len=:), allocatable, optional :: iomsg

    call get_line(input_unit, line, iostat, iomsg)
  end subroutine get_line_input_string

  !> Version: experimental
  !> 
  !> Reads a whole ASCII file and loads its contents into a string variable.
  !> The function handles error states and optionally deletes the file after reading.
  subroutine get_file_string(filename,file,err,delete) 
      !> Input file name
      character(*), intent(in) :: filename
      !> Output string variable
      type(string_type), intent(out) :: file
      !> [optional] State return flag. On error, if not requested, the code will stop.
      type(state_type), optional, intent(out) :: err
      !> [optional] Delete file after reading? Default: do not delete
      logical, optional, intent(in) :: delete
        
      ! Local variables
      character(len=:), allocatable :: filestring
      
      ! Process output
      call get_file_char(filename,filestring,err,delete)
      call move(from=fileString,to=file)

  end subroutine get_file_string

  !> Version: experimental
  !> 
  !> Reads a whole ASCII file and loads its contents into an allocatable `character` variable.
  !> The function handles error states and optionally deletes the file after reading.
  subroutine get_file_char(filename,file,err,delete) 
      !> Input file name
      character(*), intent(in) :: filename
      !> Output string variable
      character(len=:), allocatable, intent(out) :: file
      !> [optional] State return flag. On error, if not requested, the code will stop.
      type(state_type), optional, intent(out) :: err
      !> [optional] Delete file after reading? Default: do not delete
      logical, optional, intent(in) :: delete
        
      ! Local variables
      type(state_type) :: err0
      character(len=512) :: iomsg
      integer :: lun,iostat
      integer(int64) :: errpos,file_size
      logical :: is_present,want_deleted

      !> Check if the file should be deleted after reading
      if (present(delete)) then 
         want_deleted = delete
      else
         want_deleted = .false.   
      end if

      !> Check file existing
      inquire(file=filename, exist=is_present)
      if (.not.is_present) then
         allocate(character(len=0) :: file)
         err0 = state_type('get_file',STDLIB_IO_ERROR,'File not present:',filename)
         call err0%handle(err)
         return
      end if
      
      !> Retrieve file size
      inquire(file=filename,size=file_size)
      
      invalid_size: if (file_size<0) then 

          allocate(character(len=0) :: file)
          err0 = state_type('get_file',STDLIB_IO_ERROR,filename,'has invalid size=',file_size)
          call err0%handle(err)
          return            
            
      endif invalid_size  
            
      ! Read file
      open(newunit=lun,file=filename, &
           form='unformatted',action='read',access='stream',status='old', &
           iostat=iostat,iomsg=iomsg)
             
      if (iostat/=0) then 
         allocate(character(len=0) :: file)
         err0 = state_type('get_file',STDLIB_IO_ERROR,'Cannot open',filename,'for read:',iomsg)
         call err0%handle(err)
         return
      end if     
        
      allocate(character(len=file_size) :: file)
        
      read_data: if (file_size>0) then 
            
          read(lun, pos=1, iostat=iostat, iomsg=iomsg) file
            
          ! Read error
          if (iostat/=0) then 
                
              inquire(unit=lun,pos=errpos)                    
              err0 = state_type('get_file',STDLIB_IO_ERROR,iomsg,'(',filename,'at byte',errpos,')')
              call err0%handle(err)
              return

          endif
            
      end if read_data
                   
      if (want_deleted) then 
         close(lun,iostat=iostat,status='delete')
         if (iostat/=0) err0 = state_type('get_file',STDLIB_IO_ERROR,'Cannot delete',filename,'after reading')
      else
         close(lun,iostat=iostat)
         if (iostat/=0) err0 = state_type('get_file',STDLIB_IO_ERROR,'Cannot close',filename,'after reading')
      endif 
      
      ! Process output
      call err0%handle(err)

  end subroutine get_file_char

end module stdlib_io