From dbe2d49a736b9ae1c0da5d17366ce77798c88e9e Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 11:19:38 +0100 Subject: [PATCH 01/27] Generalize `state_type` -> to `module stdlib_error` --- src/CMakeLists.txt | 1 + src/stdlib_error.f90 | 84 ----- src/stdlib_error.fypp | 610 +++++++++++++++++++++++++++++++++++ src/stdlib_linalg_state.fypp | 373 ++------------------- 4 files changed, 632 insertions(+), 436 deletions(-) delete mode 100644 src/stdlib_error.f90 create mode 100644 src/stdlib_error.fypp diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index ff9f39417..e2e1b4c13 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -8,6 +8,7 @@ set(fppFiles stdlib_bitsets_large.fypp stdlib_codata_type.fypp stdlib_constants.fypp + stdlib_error.fypp stdlib_hash_32bit.fypp stdlib_hash_32bit_fnv.fypp stdlib_hash_32bit_nm.fypp diff --git a/src/stdlib_error.f90 b/src/stdlib_error.f90 deleted file mode 100644 index a44f29917..000000000 --- a/src/stdlib_error.f90 +++ /dev/null @@ -1,84 +0,0 @@ -module stdlib_error - !! Provides support for catching and handling errors - !! ([Specification](../page/specs/stdlib_error.html)) -use, intrinsic :: iso_fortran_env, only: stderr => error_unit -use stdlib_optval, only: optval -implicit none -private - -interface ! f{08,18}estop.f90 - module subroutine error_stop(msg, code) - !! version: experimental - !! - !! Provides a call to `error stop` and allows the user to specify a code and message - !! ([Specification](..//page/specs/stdlib_error.html#description_1)) - character(*), intent(in) :: msg - integer, intent(in), optional :: code - end subroutine error_stop -end interface - -public :: check, error_stop - -contains - -subroutine check(condition, msg, code, warn) - !! version: experimental - !! - !! Checks the value of a logical condition - !! ([Specification](../page/specs/stdlib_error.html#description)) - !! - !!##### Behavior - !! - !! If `condition == .false.` and: - !! - !! * No other arguments are provided, it stops the program with the default - !! message and exit code `1`; - !! * `msg` is provided, it prints the value of `msg`; - !! * `code` is provided, it stops the program with the given exit code; - !! * `warn` is provided and `.true.`, it doesn't stop the program and prints - !! the message. - !! - !!##### Examples - !! - !!* If `a /= 5`, stops the program with exit code `1` - !! and prints `Check failed.` - !!``` fortran - !! call check(a == 5) - !!``` - !! - !!* As above, but prints `a == 5 failed`. - !!``` fortran - !! call check(a == 5, msg='a == 5 failed.') - !!``` - !! - !!* As above, but doesn't stop the program. - !!``` fortran - !! call check(a == 5, msg='a == 5 failed.', warn=.true.) - !!``` - !! - !!* As example #2, but stops the program with exit code `77` - !!``` fortran - !! call check(a == 5, msg='a == 5 failed.', code=77) - !!``` - - ! - ! Arguments - ! --------- - - logical, intent(in) :: condition - character(*), intent(in), optional :: msg - integer, intent(in), optional :: code - logical, intent(in), optional :: warn - character(*), parameter :: msg_default = 'Check failed.' - - if (.not. condition) then - if (optval(warn, .false.)) then - write(stderr,*) optval(msg, msg_default) - else - call error_stop(optval(msg, msg_default), optval(code, 1)) - end if - end if - -end subroutine check - -end module stdlib_error diff --git a/src/stdlib_error.fypp b/src/stdlib_error.fypp new file mode 100644 index 000000000..2b94d32b0 --- /dev/null +++ b/src/stdlib_error.fypp @@ -0,0 +1,610 @@ +#:include "common.fypp" +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES +module stdlib_error + !! Provides support for catching and handling errors + !! ([Specification](../page/specs/stdlib_error.html)) + use, intrinsic :: iso_fortran_env, only: stderr => error_unit, ilp => int32 + use stdlib_optval, only: optval + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk + implicit none + private + + interface ! f{08,18}estop.f90 + module subroutine error_stop(msg, code) + !! version: experimental + !! + !! Provides a call to `error stop` and allows the user to specify a code and message + !! ([Specification](..//page/specs/stdlib_error.html#description_1)) + character(*), intent(in) :: msg + integer, intent(in), optional :: code + end subroutine error_stop + end interface + + public :: check, error_stop + + !> Version: experimental + !> + !> A fixed-storage state variable for error handling of linear algebra routines + public :: state_type + + !> Version: experimental + !> + !> Interfaces for comparison operators of error states with integer flags + public :: operator(==),operator(/=) + public :: operator(<),operator(<=) + public :: operator(>),operator(>=) + + !> Base state return types for + integer(ilp),parameter,public :: STDLIB_SUCCESS = 0_ilp + integer(ilp),parameter,public :: STDLIB_VALUE_ERROR = -1_ilp + integer(ilp),parameter,public :: STDLIB_LINALG_ERROR = -2_ilp + integer(ilp),parameter,public :: STDLIB_INTERNAL_ERROR = -3_ilp + integer(ilp),parameter,public :: STDLIB_IO_ERROR = -4_ilp + integer(ilp),parameter,public :: STDLIB_FS_ERROR = -5_ilp + + !> Use fixed-size character storage for performance + integer(ilp),parameter :: MSG_LENGTH = 512_ilp + integer(ilp),parameter :: NAME_LENGTH = 32_ilp + + !> `state_type` defines a general state return type for a + !> stdlib routine. State contains a status flag, a comment, and a + !> procedure specifier that can be used to mark where the error happened + type :: state_type + + !> The current exit state + integer(ilp) :: state = STDLIB_SUCCESS + + !> Message associated to the current state + character(len=MSG_LENGTH) :: message = repeat(' ',MSG_LENGTH) + + !> Location of the state change + character(len=NAME_LENGTH) :: where_at = repeat(' ',NAME_LENGTH) + + contains + + !> Cleanup + procedure :: destroy => state_destroy + + !> Parse error constructor + procedure, private :: state_parse_at_location + procedure, private :: state_parse_arguments + generic :: parse => state_parse_at_location, & + state_parse_arguments + + !> Print error message + procedure :: print => state_print + procedure :: print_msg => state_message + + !> State properties + procedure :: ok => state_is_ok + procedure :: error => state_is_error + + end type state_type + + !> Comparison operators + interface operator(==) + module procedure state_eq_flag + module procedure flag_eq_state + end interface + interface operator(/=) + module procedure state_neq_flag + module procedure flag_neq_state + end interface + interface operator(<) + module procedure state_lt_flag + module procedure flag_lt_state + end interface + interface operator(<=) + module procedure state_le_flag + module procedure flag_le_state + end interface + interface operator(>) + module procedure state_gt_flag + module procedure flag_gt_state + end interface + interface operator(>=) + module procedure state_ge_flag + module procedure flag_ge_state + end interface + + interface state_type + module procedure new_state + module procedure new_state_nowhere + end interface state_type + + !> Format strings with edit descriptors for each type and kind + !> cannot be retrieved from stdlib_io due to circular dependencies + character(*), parameter :: & + FMT_INT = '(i0)', & + FMT_REAL_SP = '(es15.8e2)', & + FMT_REAL_DP = '(es24.16e3)', & + FMT_REAL_XDP = '(es26.18e3)', & + FMT_REAL_QP = '(es44.35e4)', & + FMT_COMPLEX_SP = '(es15.8e2,1x,es15.8e2)', & + FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', & + FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', & + FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)' + +contains + + subroutine check(condition, msg, code, warn) + !! version: experimental + !! + !! Checks the value of a logical condition + !! ([Specification](../page/specs/stdlib_error.html#description)) + !! + !!##### Behavior + !! + !! If `condition == .false.` and: + !! + !! * No other arguments are provided, it stops the program with the default + !! message and exit code `1`; + !! * `msg` is provided, it prints the value of `msg`; + !! * `code` is provided, it stops the program with the given exit code; + !! * `warn` is provided and `.true.`, it doesn't stop the program and prints + !! the message. + !! + !!##### Examples + !! + !!* If `a /= 5`, stops the program with exit code `1` + !! and prints `Check failed.` + !!``` fortran + !! call check(a == 5) + !!``` + !! + !!* As above, but prints `a == 5 failed`. + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.') + !!``` + !! + !!* As above, but doesn't stop the program. + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.', warn=.true.) + !!``` + !! + !!* As example #2, but stops the program with exit code `77` + !!``` fortran + !! call check(a == 5, msg='a == 5 failed.', code=77) + !!``` + + ! + ! Arguments + ! --------- + + logical, intent(in) :: condition + character(*), intent(in), optional :: msg + integer, intent(in), optional :: code + logical, intent(in), optional :: warn + character(*), parameter :: msg_default = 'Check failed.' + + if (.not. condition) then + if (optval(warn, .false.)) then + write(stderr,*) optval(msg, msg_default) + else + call error_stop(optval(msg, msg_default), optval(code, 1)) + end if + end if + + end subroutine check + + !> Cleanup the object + elemental subroutine state_destroy(this) + class(state_type),intent(inout) :: this + + this%state = STDLIB_SUCCESS + this%message = repeat(' ',len(this%message)) + this%where_at = repeat(' ',len(this%where_at)) + + end subroutine state_destroy + + !> Interface to print stdlib error messages + pure function state_flag_message(flag) result(msg) + integer(ilp),intent(in) :: flag + character(len=:),allocatable :: msg + + select case (flag) + case (STDLIB_SUCCESS); msg = 'Success!' + case (STDLIB_VALUE_ERROR); msg = 'Value Error' + case (STDLIB_LINALG_ERROR); msg = 'Linear Algebra Error' + case (STDLIB_IO_ERROR); msg = 'I/O Error' + case (STDLIB_FS_ERROR); msg = 'Filesystem Error' + case (STDLIB_INTERNAL_ERROR); msg = 'Internal Error' + case default; msg = 'INVALID/UNKNOWN STATE FLAG' + end select + + end function state_flag_message + + !> Return a formatted message + pure function state_message(this) result(msg) + class(state_type),intent(in) :: this + character(len=:),allocatable :: msg + + if (this%state == STDLIB_SUCCESS) then + msg = 'Success!' + else + msg = state_flag_message(this%state)//': '//trim(this%message) + end if + + end function state_message + + !> Produce a nice error string + pure function state_print(this) result(msg) + class(state_type),intent(in) :: this + character(len=:),allocatable :: msg + + if (len_trim(this%where_at) > 0) then + msg = '['//trim(this%where_at)//'] returned '//this%print_msg() + elseif (this%error()) then + msg = 'Error encountered: '//this%print_msg() + else + msg = this%print_msg() + end if + + end function state_print + + !> Check if the current state is successful + elemental logical(lk) function state_is_ok(this) + class(state_type),intent(in) :: this + state_is_ok = this%state == STDLIB_SUCCESS + end function state_is_ok + + !> Check if the current state is an error state + elemental logical(lk) function state_is_error(this) + class(state_type),intent(in) :: this + state_is_error = this%state /= STDLIB_SUCCESS + end function state_is_error + + !> Compare an error state with an integer flag + elemental logical(lk) function state_eq_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_eq_flag = err%state == flag + end function state_eq_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_eq_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_eq_state = err%state == flag + end function flag_eq_state + + !> Compare the error state with an integer flag + elemental logical(lk) function state_neq_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_neq_flag = .not. state_eq_flag(err,flag) + end function state_neq_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_neq_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_neq_state = .not. state_eq_flag(err,flag) + end function flag_neq_state + + !> Compare the error state with an integer flag + elemental logical(lk) function state_lt_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_lt_flag = err%state < flag + end function state_lt_flag + + !> Compare the error state with an integer flag + elemental logical(lk) function state_le_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_le_flag = err%state <= flag + end function state_le_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_lt_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_lt_state = err%state < flag + end function flag_lt_state + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_le_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_le_state = err%state <= flag + end function flag_le_state + + !> Compare the error state with an integer flag + elemental logical(lk) function state_gt_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_gt_flag = err%state > flag + end function state_gt_flag + + !> Compare the error state with an integer flag + elemental logical(lk) function state_ge_flag(err,flag) + class(state_type),intent(in) :: err + integer,intent(in) :: flag + state_ge_flag = err%state >= flag + end function state_ge_flag + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_gt_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_gt_state = err%state > flag + end function flag_gt_state + + !> Compare an integer flag with the error state + elemental logical(lk) function flag_ge_state(flag,err) + integer,intent(in) :: flag + class(state_type),intent(in) :: err + flag_ge_state = err%state >= flag + end function flag_ge_state + + !> Append a generic value to the error flag (rank-agnostic) + pure subroutine appendr(msg,a,prefix) + class(*),optional,intent(in) :: a(..) + character(len=*),intent(inout) :: msg + character,optional,intent(in) :: prefix + + if (present(a)) then + select rank (v=>a) + rank (0) + call append (msg,v,prefix) + rank (1) + call appendv(msg,v) + rank default + msg = trim(msg)//' ' + + end select + endif + + end subroutine appendr + + ! Append a generic value to the error flag + pure subroutine append(msg,a,prefix) + class(*),intent(in) :: a + character(len=*),intent(inout) :: msg + character,optional,intent(in) :: prefix + + character(len=MSG_LENGTH) :: buffer,buffer2 + character(len=2) :: sep + integer :: ls + + ! Do not add separator if this is the first instance + sep = ' ' + ls = merge(1,0,len_trim(msg) > 0) + + if (present(prefix)) then + ls = ls + 1 + sep(ls:ls) = prefix + end if + + select type (aa => a) + + !> String type + type is (character(len=*)) + msg = trim(msg)//sep(:ls)//aa + + !> Numeric types +#:for k1, t1 in KINDS_TYPES + type is (${t1}$) + #:if 'complex' in t1 + write (buffer, FMT_REAL_${k1}$) aa%re + write (buffer2,FMT_REAL_${k1}$) aa%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + #:else + #:if 'real' in t1 + write (buffer,FMT_REAL_${k1}$) aa + #:else + write (buffer,FMT_INT) aa + #:endif + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + #:endif + +#:endfor + class default + msg = trim(msg)//' ' + + end select + + end subroutine append + + !> Append a generic vector to the error flag + pure subroutine appendv(msg,a) + class(*),intent(in) :: a(:) + character(len=*),intent(inout) :: msg + + integer :: j,ls + character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format + character(len=2) :: sep + + if (size(a) <= 0) return + + ! Default: separate elements with one space + sep = ' ' + ls = 1 + + ! Open bracket + msg = trim(msg)//' [' + + ! Do not call append(msg(aa(j))), it will crash gfortran + select type (aa => a) + + !> Strings (cannot use string_type due to `sequence`) + type is (character(len=*)) + msg = trim(msg)//adjustl(aa(1)) + do j = 2,size(a) + msg = trim(msg)//sep(:ls)//adjustl(aa(j)) + end do + + !> Numeric types +#:for k1, t1 in KINDS_TYPES + type is (${t1}$) + #:if 'complex' in t1 + write (buffer,FMT_REAL_${k1}$) aa(1)%re + write (buffer2,FMT_REAL_${k1}$) aa(1)%im + msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + do j = 2,size(a) + write (buffer,FMT_REAL_${k1}$) aa(j)%re + write (buffer2,FMT_REAL_${k1}$) aa(j)%im + msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' + end do + #:else + #:if 'real' in t1 + buffer_format = FMT_REAL_${k1}$ + #:else + buffer_format = FMT_INT + #:endif + + write (buffer,buffer_format) aa(1) + msg = trim(msg)//adjustl(buffer) + do j = 2,size(a) + write (buffer,buffer_format) aa(j) + msg = trim(msg)//sep(:ls)//adjustl(buffer) + end do + msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) + #:endif +#:endfor + class default + msg = trim(msg)//' ' + + end select + + ! Close bracket + msg = trim(msg)//']' + + end subroutine appendv + + !> Error creation message, with location location + pure type(state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + !> Location + character(len=*),intent(in) :: where_at + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%parse(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + end function new_state + + !> Error creation message, from N input variables (numeric or strings) + pure type(state_type) function new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) & + result(new_state) + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%parse(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + end function new_state_nowhere + + !> Parse a generic list of arguments provided to the error constructor + pure subroutine state_parse_at_location(new_state,where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + !> The current state variable + class(state_type), intent(inout) :: new_state + + !> Error Location + character(len=*),intent(in) :: where_at + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%destroy() + + !> Set error flag + new_state%state = flag + + !> Set chain + new_state%message = "" + call appendr(new_state%message,a1) + call appendr(new_state%message,a2) + call appendr(new_state%message,a3) + call appendr(new_state%message,a4) + call appendr(new_state%message,a5) + call appendr(new_state%message,a6) + call appendr(new_state%message,a7) + call appendr(new_state%message,a8) + call appendr(new_state%message,a9) + call appendr(new_state%message,a10) + call appendr(new_state%message,a11) + call appendr(new_state%message,a12) + call appendr(new_state%message,a13) + call appendr(new_state%message,a14) + call appendr(new_state%message,a15) + call appendr(new_state%message,a16) + call appendr(new_state%message,a17) + call appendr(new_state%message,a18) + call appendr(new_state%message,a19) + call appendr(new_state%message,a20) + + !> Add location + if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at) + + end subroutine state_parse_at_location + + !> Parse a generic list of arguments provided to the error constructor + pure subroutine state_parse_arguments(new_state,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) + + !> The current state variable + class(state_type), intent(inout) :: new_state + + !> Input error flag + integer,intent(in) :: flag + + !> Optional rank-agnostic arguments + class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 + + ! Init object + call new_state%destroy() + + !> Set error flag + new_state%state = flag + + !> Set chain + new_state%message = "" + call appendr(new_state%message,a1) + call appendr(new_state%message,a2) + call appendr(new_state%message,a3) + call appendr(new_state%message,a4) + call appendr(new_state%message,a5) + call appendr(new_state%message,a6) + call appendr(new_state%message,a7) + call appendr(new_state%message,a8) + call appendr(new_state%message,a9) + call appendr(new_state%message,a10) + call appendr(new_state%message,a11) + call appendr(new_state%message,a12) + call appendr(new_state%message,a13) + call appendr(new_state%message,a14) + call appendr(new_state%message,a15) + call appendr(new_state%message,a16) + call appendr(new_state%message,a17) + call appendr(new_state%message,a18) + call appendr(new_state%message,a19) + call appendr(new_state%message,a20) + + end subroutine state_parse_arguments + +end module stdlib_error diff --git a/src/stdlib_linalg_state.fypp b/src/stdlib_linalg_state.fypp index b261dc223..7d39446c3 100644 --- a/src/stdlib_linalg_state.fypp +++ b/src/stdlib_linalg_state.fypp @@ -8,8 +8,8 @@ module stdlib_linalg_state !! ([Specification](../page/specs/stdlib_linalg.html)) use stdlib_linalg_constants,only: ilp use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp, lk - use stdlib_io, only: FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_QP, FMT_COMPLEX_SP, FMT_COMPLEX_DP, & - FMT_COMPLEX_QP, FMT_REAL_XDP, FMT_COMPLEX_XDP + use stdlib_error, only: state_type, operator(==), operator(/=), operator(<), operator(>), & + operator(<=), operator(>=), STDLIB_SUCCESS, STDLIB_VALUE_ERROR, STDLIB_LINALG_ERROR, STDLIB_INTERNAL_ERROR implicit none(type,external) private @@ -31,75 +31,27 @@ module stdlib_linalg_state public :: operator(<),operator(<=) public :: operator(>),operator(>=) - !> State return types - integer(ilp),parameter,public :: LINALG_SUCCESS = 0_ilp - integer(ilp),parameter,public :: LINALG_VALUE_ERROR = -1_ilp - integer(ilp),parameter,public :: LINALG_ERROR = -2_ilp - integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = -3_ilp - - !> Use fixed-size character storage for performance - integer(ilp),parameter :: MSG_LENGTH = 512_ilp - integer(ilp),parameter :: NAME_LENGTH = 32_ilp + !> State return types for linear algebra + integer(ilp),parameter,public :: LINALG_SUCCESS = STDLIB_SUCCESS + integer(ilp),parameter,public :: LINALG_VALUE_ERROR = STDLIB_VALUE_ERROR + integer(ilp),parameter,public :: LINALG_ERROR = STDLIB_LINALG_ERROR + integer(ilp),parameter,public :: LINALG_INTERNAL_ERROR = STDLIB_INTERNAL_ERROR !> `linalg_state_type` defines a state return type for a !> linear algebra routine. State contains a status flag, a comment, and a !> procedure specifier that can be used to mark where the error happened - type :: linalg_state_type - - !> The current exit state - integer(ilp) :: state = LINALG_SUCCESS - - !> Message associated to the current state - character(len=MSG_LENGTH) :: message = repeat(' ',MSG_LENGTH) - - !> Location of the state change - character(len=NAME_LENGTH) :: where_at = repeat(' ',NAME_LENGTH) - + type, extends(state_type) :: linalg_state_type contains - - !> Cleanup - procedure :: destroy => state_destroy - - !> Print error message - procedure :: print => state_print - procedure :: print_msg => state_message - - !> State properties - procedure :: ok => state_is_ok - procedure :: error => state_is_error - + + !> Print error message + procedure :: print_msg => state_message + end type linalg_state_type - !> Comparison operators - interface operator(==) - module procedure state_eq_flag - module procedure flag_eq_state - end interface - interface operator(/=) - module procedure state_neq_flag - module procedure flag_neq_state - end interface - interface operator(<) - module procedure state_lt_flag - module procedure flag_lt_state - end interface - interface operator(<=) - module procedure state_le_flag - module procedure flag_le_state - end interface - interface operator(>) - module procedure state_gt_flag - module procedure flag_gt_state - end interface - interface operator(>=) - module procedure state_ge_flag - module procedure flag_ge_state - end interface - - interface linalg_state_type - module procedure new_state - module procedure new_state_nowhere - end interface linalg_state_type + interface linalg_state_type + module procedure new_state + module procedure new_state_nowhere + end interface linalg_state_type contains @@ -148,127 +100,6 @@ module stdlib_linalg_state end function state_message - !> Produce a nice error string - pure function state_print(this) result(msg) - class(linalg_state_type),intent(in) :: this - character(len=:),allocatable :: msg - - if (len_trim(this%where_at) > 0) then - msg = '['//trim(this%where_at)//'] returned '//state_message(this) - elseif (this%error()) then - msg = 'Error encountered: '//state_message(this) - else - msg = state_message(this) - end if - - end function state_print - - !> Cleanup the object - elemental subroutine state_destroy(this) - class(linalg_state_type),intent(inout) :: this - - this%state = LINALG_SUCCESS - this%message = repeat(' ',len(this%message)) - this%where_at = repeat(' ',len(this%where_at)) - - end subroutine state_destroy - - !> Check if the current state is successful - elemental logical(lk) function state_is_ok(this) - class(linalg_state_type),intent(in) :: this - state_is_ok = this%state == LINALG_SUCCESS - end function state_is_ok - - !> Check if the current state is an error state - elemental logical(lk) function state_is_error(this) - class(linalg_state_type),intent(in) :: this - state_is_error = this%state /= LINALG_SUCCESS - end function state_is_error - - !> Compare an error state with an integer flag - elemental logical(lk) function state_eq_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_eq_flag = err%state == flag - end function state_eq_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_eq_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_eq_state = err%state == flag - end function flag_eq_state - - !> Compare the error state with an integer flag - elemental logical(lk) function state_neq_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_neq_flag = .not. state_eq_flag(err,flag) - end function state_neq_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_neq_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_neq_state = .not. state_eq_flag(err,flag) - end function flag_neq_state - - !> Compare the error state with an integer flag - elemental logical(lk) function state_lt_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_lt_flag = err%state < flag - end function state_lt_flag - - !> Compare the error state with an integer flag - elemental logical(lk) function state_le_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_le_flag = err%state <= flag - end function state_le_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_lt_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_lt_state = err%state < flag - end function flag_lt_state - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_le_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_le_state = err%state <= flag - end function flag_le_state - - !> Compare the error state with an integer flag - elemental logical(lk) function state_gt_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_gt_flag = err%state > flag - end function state_gt_flag - - !> Compare the error state with an integer flag - elemental logical(lk) function state_ge_flag(err,flag) - type(linalg_state_type),intent(in) :: err - integer,intent(in) :: flag - state_ge_flag = err%state >= flag - end function state_ge_flag - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_gt_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_gt_state = err%state > flag - end function flag_gt_state - - !> Compare an integer flag with the error state - elemental logical(lk) function flag_ge_state(flag,err) - integer,intent(in) :: flag - type(linalg_state_type),intent(in) :: err - flag_ge_state = err%state >= flag - end function flag_ge_state - !> Error creation message, with location location pure type(linalg_state_type) function new_state(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) @@ -283,12 +114,9 @@ module stdlib_linalg_state class(*),optional,intent(in),dimension(..) :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 - !> Create state with no message - new_state = new_state_nowhere(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & - a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) - - !> Add location - if (len_trim(where_at) > 0) new_state%where_at = adjustl(where_at) + ! Init object + call new_state%parse(where_at,flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) end function new_state @@ -305,169 +133,10 @@ module stdlib_linalg_state a11,a12,a13,a14,a15,a16,a17,a18,a19,a20 ! Init object - call new_state%destroy() - - !> Set error flag - new_state%state = flag - - !> Set chain - new_state%message = "" - call appendr(new_state%message,a1) - call appendr(new_state%message,a2) - call appendr(new_state%message,a3) - call appendr(new_state%message,a4) - call appendr(new_state%message,a5) - call appendr(new_state%message,a6) - call appendr(new_state%message,a7) - call appendr(new_state%message,a8) - call appendr(new_state%message,a9) - call appendr(new_state%message,a10) - call appendr(new_state%message,a11) - call appendr(new_state%message,a12) - call appendr(new_state%message,a13) - call appendr(new_state%message,a14) - call appendr(new_state%message,a15) - call appendr(new_state%message,a16) - call appendr(new_state%message,a17) - call appendr(new_state%message,a18) - call appendr(new_state%message,a19) - call appendr(new_state%message,a20) + call new_state%parse(flag,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10, & + a11,a12,a13,a14,a15,a16,a17,a18,a19,a20) end function new_state_nowhere - !> Append a generic value to the error flag (rank-agnostic) - pure subroutine appendr(msg,a,prefix) - class(*),optional,intent(in) :: a(..) - character(len=*),intent(inout) :: msg - character,optional,intent(in) :: prefix - - if (present(a)) then - select rank (v=>a) - rank (0) - call append (msg,v,prefix) - rank (1) - call appendv(msg,v) - rank default - msg = trim(msg)//' ' - - end select - endif - - end subroutine appendr - - ! Append a generic value to the error flag - pure subroutine append(msg,a,prefix) - class(*),intent(in) :: a - character(len=*),intent(inout) :: msg - character,optional,intent(in) :: prefix - - character(len=MSG_LENGTH) :: buffer,buffer2 - character(len=2) :: sep - integer :: ls - - ! Do not add separator if this is the first instance - sep = ' ' - ls = merge(1,0,len_trim(msg) > 0) - - if (present(prefix)) then - ls = ls + 1 - sep(ls:ls) = prefix - end if - - select type (aa => a) - - !> String type - type is (character(len=*)) - msg = trim(msg)//sep(:ls)//aa - - !> Numeric types -#:for k1, t1 in KINDS_TYPES - type is (${t1}$) - #:if 'complex' in t1 - write (buffer, FMT_REAL_${k1}$) aa%re - write (buffer2,FMT_REAL_${k1}$) aa%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - #:else - #:if 'real' in t1 - write (buffer,FMT_REAL_${k1}$) aa - #:else - write (buffer,'(i0)') aa - #:endif - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - #:endif - -#:endfor - class default - msg = trim(msg)//' ' - - end select - - end subroutine append - - !> Append a generic vector to the error flag - pure subroutine appendv(msg,a) - class(*),intent(in) :: a(:) - character(len=*),intent(inout) :: msg - - integer :: j,ls - character(len=MSG_LENGTH) :: buffer,buffer2,buffer_format - character(len=2) :: sep - - if (size(a) <= 0) return - - ! Default: separate elements with one space - sep = ' ' - ls = 1 - - ! Open bracket - msg = trim(msg)//' [' - - ! Do not call append(msg(aa(j))), it will crash gfortran - select type (aa => a) - - !> Strings (cannot use string_type due to `sequence`) - type is (character(len=*)) - msg = trim(msg)//adjustl(aa(1)) - do j = 2,size(a) - msg = trim(msg)//sep(:ls)//adjustl(aa(j)) - end do - - !> Numeric types -#:for k1, t1 in KINDS_TYPES - type is (${t1}$) - #:if 'complex' in t1 - write (buffer,FMT_REAL_${k1}$) aa(1)%re - write (buffer2,FMT_REAL_${k1}$) aa(1)%im - msg = trim(msg)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - do j = 2,size(a) - write (buffer,FMT_REAL_${k1}$) aa(j)%re - write (buffer2,FMT_REAL_${k1}$) aa(j)%im - msg = trim(msg)//sep(:ls)//'('//trim(adjustl(buffer))//','//trim(adjustl(buffer2))//')' - end do - #:else - #:if 'real' in t1 - buffer_format = FMT_REAL_${k1}$ - #:else - buffer_format = '(i0)' - #:endif - - write (buffer,buffer_format) aa(1) - msg = trim(msg)//adjustl(buffer) - do j = 2,size(a) - write (buffer,buffer_format) aa(j) - msg = trim(msg)//sep(:ls)//adjustl(buffer) - end do - msg = trim(msg)//sep(:ls)//trim(adjustl(buffer)) - #:endif -#:endfor - class default - msg = trim(msg)//' ' - - end select - - ! Close bracket - msg = trim(msg)//']' - - end subroutine appendv end module stdlib_linalg_state From 0fecec474376e02f75affda9931d499f8d0c8995 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 11:31:43 +0100 Subject: [PATCH 02/27] add `io_filesystem` module --- src/CMakeLists.txt | 1 + src/stdlib_io_filesystem.F90 | 11 +++++++++++ 2 files changed, 12 insertions(+) create mode 100644 src/stdlib_io_filesystem.F90 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index e2e1b4c13..a635dd91d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -116,6 +116,7 @@ set(SRC stdlib_hashmaps.f90 stdlib_hashmap_chaining.f90 stdlib_hashmap_open.f90 + stdlib_io_filesystem.F90 stdlib_logger.f90 stdlib_sorting_radix_sort.f90 stdlib_system.F90 diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 new file mode 100644 index 000000000..4fb492561 --- /dev/null +++ b/src/stdlib_io_filesystem.F90 @@ -0,0 +1,11 @@ +! SPDX-Identifier: MIT + +!> Interaction with the filesystem. +module stdlib_io_filesystem + use stdlib_string_type, only: string_type + implicit none + private + +contains + +end module stdlib_io_filesystem From 668bd1c91348e216da51b92620bcd946b4b292f0 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 11:36:10 +0100 Subject: [PATCH 03/27] add filesystem test program --- test/io/CMakeLists.txt | 1 + test/io/test_filesystem.f90 | 49 +++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+) create mode 100644 test/io/test_filesystem.f90 diff --git a/test/io/CMakeLists.txt b/test/io/CMakeLists.txt index 98794cd88..77a12c323 100644 --- a/test/io/CMakeLists.txt +++ b/test/io/CMakeLists.txt @@ -13,6 +13,7 @@ ADDTEST(savetxt_qp) set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision) set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision) +ADDTEST(filesystem) ADDTEST(getline) ADDTEST(npy) ADDTEST(open) diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 new file mode 100644 index 000000000..f4032578a --- /dev/null +++ b/test/io/test_filesystem.f90 @@ -0,0 +1,49 @@ +module test_filesystem + use stdlib_io_filesystem + use stdlib_string_type, only: char, string_type + use testdrive, only: new_unittest, unittest_type, error_type, check, test_failed + implicit none + private + + public :: collect_filesystem + + character(*), parameter :: temp_list_dir = 'temp_list_dir' + +contains + + !> Collect all exported unit tests + subroutine collect_filesystem(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + allocate(testsuite(0)) + + end subroutine collect_filesystem + +end module test_filesystem + +program test_all_filesystem + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_filesystem, only : collect_filesystem + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("filesystem", collect_filesystem) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program test_all_filesystem From 354c75c1e21e53c2a418003c0d3ef6c328e79a0a Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 11:54:52 +0100 Subject: [PATCH 04/27] `state_type`: add assignment operator --- src/stdlib_error.fypp | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/src/stdlib_error.fypp b/src/stdlib_error.fypp index 2b94d32b0..61bab895a 100644 --- a/src/stdlib_error.fypp +++ b/src/stdlib_error.fypp @@ -78,6 +78,9 @@ module stdlib_error !> State properties procedure :: ok => state_is_ok procedure :: error => state_is_error + + !> Handle optional error message + procedure :: handle => error_handling end type state_type @@ -106,6 +109,11 @@ module stdlib_error module procedure state_ge_flag module procedure flag_ge_state end interface + + !> Assignment operator + interface assignment(=) + module procedure state_assign_state + end interface assignment(=) interface state_type module procedure new_state @@ -227,6 +235,23 @@ contains end function state_message + !> Flow control: on output flag present, return it; otherwise, halt on error + pure subroutine error_handling(ierr,ierr_out) + class(state_type), intent(in) :: ierr + class(state_type), optional, intent(inout) :: ierr_out + + character(len=:),allocatable :: err_msg + + if (present(ierr_out)) then + ! Return error flag + ierr_out = ierr + elseif (ierr%error()) then + err_msg = ierr%print() + error stop err_msg + end if + + end subroutine error_handling + !> Produce a nice error string pure function state_print(this) result(msg) class(state_type),intent(in) :: this @@ -338,6 +363,17 @@ contains flag_ge_state = err%state >= flag end function flag_ge_state + !> Assign a state type to another + elemental subroutine state_assign_state(to, from) + class(state_type), intent(inout) :: to + class(state_type), intent(in) :: from + + to%state = from%state + to%message = from%message + to%where_at = from%where_at + + end subroutine state_assign_state + !> Append a generic value to the error flag (rank-agnostic) pure subroutine appendr(msg,a,prefix) class(*),optional,intent(in) :: a(..) From 4b01b33c8f3670d6183949535951e53f4ec867da Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 11:55:00 +0100 Subject: [PATCH 05/27] filesystem: `delete_file` --- src/stdlib_io_filesystem.F90 | 38 ++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index 4fb492561..a5edc53a9 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -3,9 +3,47 @@ !> Interaction with the filesystem. module stdlib_io_filesystem use stdlib_string_type, only: string_type + use stdlib_error, only: state_type, STDLIB_FS_ERROR implicit none private contains + subroutine delete_file(filename, err) + character(*), intent(in) :: filename + type(state_type), optional, intent(out) :: err + + !> Local variables + integer :: file_unit, ios + type(state_type) :: err0 + character(len=512) :: msg + logical :: file_exists + + ! Check if the filename is a file or a directory by inquiring about its existence + inquire(file=filename, exist=file_exists) + if (.not. file_exists) then + ! File does not exist, return error status + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,': file does not exist') + call err0%handle(err) + return + endif + + ! Try opening the file in read-only mode to verify it is a file, not a directory + open(newunit=file_unit, file=filename, status="old", action="read", iostat=ios, iomsg=msg) + if (ios /= 0) then + ! If unable to open, assume it's a directory or inaccessible + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,':',msg) + call err0%handle(err) + return + end if + + ! Close and delete the file + close(unit=file_unit, status="delete", iostat=ios, iomsg=msg) + if (ios /= 0) then + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,':',msg) + call err0%handle(err) + return + end if + end subroutine delete_file + end module stdlib_io_filesystem From f1aa61af52e79eaeb927c5ec9b424194f0d14ac3 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 12:02:12 +0100 Subject: [PATCH 06/27] add tests --- src/stdlib_io_filesystem.F90 | 2 ++ test/io/test_filesystem.f90 | 54 +++++++++++++++++++++++++++++++++++- 2 files changed, 55 insertions(+), 1 deletion(-) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index a5edc53a9..7cf71dcaa 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -6,6 +6,8 @@ module stdlib_io_filesystem use stdlib_error, only: state_type, STDLIB_FS_ERROR implicit none private + + public :: delete_file contains diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 index f4032578a..7ef7df862 100644 --- a/test/io/test_filesystem.f90 +++ b/test/io/test_filesystem.f90 @@ -1,6 +1,6 @@ module test_filesystem use stdlib_io_filesystem - use stdlib_string_type, only: char, string_type + use stdlib_error, only: state_type use testdrive, only: new_unittest, unittest_type, error_type, check, test_failed implicit none private @@ -18,8 +18,60 @@ subroutine collect_filesystem(testsuite) allocate(testsuite(0)) + testsuite = [ & + new_unittest("fs_delete_non_existent", test_delete_file_non_existent), & + new_unittest("fs_delete_existing_file", test_delete_file_existing) & + ] + end subroutine collect_filesystem + subroutine test_delete_file_non_existent(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(state_type) :: state + + ! Attempt to delete a file that doesn't exist + call delete_file('non_existent_file_blurp.txt', state) + + call check(error, state%error(), 'Error should be triggered for non-existent file') + if (allocated(error)) return + + end subroutine test_delete_file_non_existent + + subroutine test_delete_file_existing(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=256) :: filename + type(state_type) :: state + integer :: ios,iunit + logical :: is_present + character(len=512) :: msg + + filename = 'existing_file.txt' + + ! Create a file to be deleted + open(newunit=iunit, file=filename, status='replace', iostat=ios, iomsg=msg) + call check(error, ios==0, 'Failed to create test file') + if (allocated(error)) return + close(iunit) + + ! Attempt to delete the existing file + call delete_file(filename, state) + + ! Check deletion successful + call check(error, state%ok(), state%print()) + if (allocated(error)) return + + ! Check if the file was successfully deleted (should no longer exist) + inquire(file=filename, exist=is_present) + + call check(error, .not.is_present, 'File still present after delete') + if (allocated(error)) return + + end subroutine test_delete_file_existing + + end module test_filesystem program test_all_filesystem From 710d3225c7988efbf93fb1fc1c1e7c4973c3ee8e Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Sun, 8 Dec 2024 20:20:24 +0100 Subject: [PATCH 07/27] runtime OS type evaluation --- src/stdlib_system.F90 | 144 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 144 insertions(+) diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 7bcc78baf..f65eb200b 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -4,6 +4,24 @@ module stdlib_system private public :: sleep +!! OS type inquiry + public :: OS_NAME + public :: OS_TYPE + +!! Public parameters defining known OS types +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 + +!! Static storage for the current OS +logical :: have_os = .false. +integer :: OS_CURRENT = OS_UNKNOWN + interface #ifdef _WIN32 subroutine winsleep(dwMilliseconds) bind (C, name='Sleep') @@ -46,4 +64,130 @@ subroutine sleep(millisec) end subroutine sleep +!> Determine the current OS type +integer function OS_TYPE() result(os) + if (have_os) then + os = OS_CURRENT + else + OS_CURRENT = runtime_os() + have_os = .true. + os = OS_CURRENT + end if +end function OS_TYPE + +!> Determine the current OS type at runtime +integer function runtime_os() result(os) + !! + !! 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 + + os = 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 + os = OS_LINUX + return + end if + + ! macOS + if (index(val, 'darwin') > 0) then + os = OS_MACOS + return + end if + + ! Windows, MSYS, MinGW, Git Bash + if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then + os = OS_WINDOWS + return + end if + + ! Cygwin + if (index(val, 'cygwin') > 0) then + os = OS_CYGWIN + return + end if + + ! Solaris, OpenIndiana, ... + if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then + os = OS_SOLARIS + return + end if + + ! FreeBSD + if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then + os = OS_FREEBSD + return + end if + + ! OpenBSD + if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then + os = OS_OPENBSD + 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 + os = OS_WINDOWS + return + end if + + ! Linux + inquire (file='/etc/os-release', exist=file_exists) + + if (file_exists) then + os = OS_LINUX + return + end if + + ! macOS + inquire (file='/usr/bin/sw_vers', exist=file_exists) + + if (file_exists) then + os = OS_MACOS + return + end if + + ! FreeBSD + inquire (file='/bin/freebsd-version', exist=file_exists) + + if (file_exists) then + os = OS_FREEBSD + return + end if +end function runtime_os + +!> 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 default ; OS_NAME = "Unknown" + end select +end function OS_NAME + end module stdlib_system From b4a89008783e7a2661c497deaaec6c5de4a6f334 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 09:34:05 +0100 Subject: [PATCH 08/27] add `is_directory` --- src/stdlib_io_filesystem.F90 | 103 +++++++++++++++++++++++++++++++++-- test/io/test_filesystem.f90 | 32 ++++++++++- 2 files changed, 130 insertions(+), 5 deletions(-) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index 7cf71dcaa..734ef0dc1 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -4,6 +4,7 @@ module stdlib_io_filesystem use stdlib_string_type, only: string_type use stdlib_error, only: state_type, STDLIB_FS_ERROR + use stdlib_system, only: OS_TYPE implicit none private @@ -11,6 +12,31 @@ module stdlib_io_filesystem contains + !> test if a name matches an existing directory path. + !> Cross-platform version that does not use C externals + logical function is_directory(path) + character(*), intent(in) :: path + + integer :: ios + + + select case (get_os_type()) + + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + call execute_command_line("test -d " // dir, & + & exitstat=stat,echo=.false.,verbose=.false.) + + case (OS_WINDOWS) + call run('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', & + & exitstat=stat,echo=.false.,verbose=.false.) + + end select + + is_directory = stat == 0 + + end function is_directory + + subroutine delete_file(filename, err) character(*), intent(in) :: filename type(state_type), optional, intent(out) :: err @@ -30,11 +56,16 @@ subroutine delete_file(filename, err) return endif - ! Try opening the file in read-only mode to verify it is a file, not a directory - open(newunit=file_unit, file=filename, status="old", action="read", iostat=ios, iomsg=msg) + ! Try opening the file in "readwrite" mode to verify it is a file, not a directory + ! Because we're trying to delete the file, we need write access anyways. This will + ! be forbidden if this is a directory + open(newunit=file_unit, file=filename, status="old", action="readwrite", iostat=ios, iomsg=msg) + + print *, 'IOS ',ios,' IOMSG ',trim(msg) + if (ios /= 0) then ! If unable to open, assume it's a directory or inaccessible - err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,':',msg) + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,'-',msg) call err0%handle(err) return end if @@ -42,10 +73,74 @@ subroutine delete_file(filename, err) ! Close and delete the file close(unit=file_unit, status="delete", iostat=ios, iomsg=msg) if (ios /= 0) then - err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,':',msg) + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,'-',msg) call err0%handle(err) return end if end subroutine delete_file + ! Run a command + subroutine run(cmd,exitstat,cmdstat,cmdmsg,screen_output) + character(len=*), intent(in) :: cmd + integer, intent(out), optional :: exitstat,cmdstat + character(*), optional, intent(out) :: cmdmsg + type(string_type), optional, intent(out) :: screen_output + + character(len=256) :: iomsg + logical :: want_output + character(:), allocatable :: redirect_str,redirect_file + integer :: cstat, stat, fh, iostat + + want_output = present(screen_output) + + if (want_output) then + + ! Redirect output to a file + redirect_file = scratch_name() + redirect_str = ">"//redirect_file//" 2>&1" + + else + ! No redirection and non-verbose output + if (os_is_unix()) then + redirect_str = " >/dev/null 2>&1" + else + redirect_str = " >NUL 2>&1" + end if + + end if + + call execute_command_line(cmd//redirect_str, exitstat=stat,cmdstat=cstat,cmdmsg=iomsg) + + if (want_output) then + call screen_output%read_ascii_file(redirect_file,iostat=iostat,iomsg=iomsg,delete=.true.) + end if + + if (present(exitstat)) then + exitstat = stat + elseif (stat /= 0) then + error stop 'Cannot run '//cmd + end if + + if (present(cmdstat)) cmdstat = cstat + if (present(cmdmsg)) cmdmsg = iomsg + + end subroutine run + + !> Replace file system separators for windows + function windows_path(path) result(winpath) + + character(*), intent(in) :: path + character(len(path)) :: winpath + + integer :: idx + + winpath = path + idx = index(winpath,'/') + do while(idx > 0) + winpath(idx:idx) = '\' + idx = index(winpath,'/') + end do + + end function windows_path + end module stdlib_io_filesystem diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 index 7ef7df862..47ff474a8 100644 --- a/test/io/test_filesystem.f90 +++ b/test/io/test_filesystem.f90 @@ -20,7 +20,8 @@ subroutine collect_filesystem(testsuite) testsuite = [ & new_unittest("fs_delete_non_existent", test_delete_file_non_existent), & - new_unittest("fs_delete_existing_file", test_delete_file_existing) & + new_unittest("fs_delete_existing_file", test_delete_file_existing), & + new_unittest("fd_delete_file_being_dir", test_delete_directory) & ] end subroutine collect_filesystem @@ -71,6 +72,35 @@ subroutine test_delete_file_existing(error) end subroutine test_delete_file_existing + subroutine test_delete_directory(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=256) :: filename + type(state_type) :: state + integer :: ios,iocmd + character(len=512) :: msg + + filename = 'test_directory' + + ! The directory is not nested: it should be cross-platform to just call `mkdir` + call execute_command_line('mkdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios==0 .and. iocmd==0, 'Cannot init delete_directory test: '//trim(msg)) + if (allocated(error)) return + + ! Attempt to delete a directory (which should fail) + call delete_file(filename, state) + + ! Check that an error was raised since the target is a directory + call check(error, state%ok(), 'Error was not triggered trying to delete directory') + if (allocated(error)) return + + ! Clean up: remove the empty directory + call execute_command_line('rmdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup delete_directory test: '//trim(msg)) + if (allocated(error)) return + + end subroutine test_delete_directory + end module test_filesystem From 66301ef9e21de694e6976502899b214e445e22f3 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 03:30:47 -0600 Subject: [PATCH 09/27] implement `getfile` --- src/stdlib_io.fypp | 91 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 88 insertions(+), 3 deletions(-) diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index 556d0281f..825b86845 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -9,14 +9,14 @@ module stdlib_io 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 + 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 + use stdlib_string_type implicit none private ! Public API - public :: loadtxt, savetxt, open, getline + public :: loadtxt, savetxt, open, getline, getfile ! Private API that is exposed so that we can test it in tests public :: parse_mode @@ -524,4 +524,89 @@ contains call getline(input_unit, line, iostat, iomsg) end subroutine getline_input_string + !> Version: experimental + !> + !> Read a whole ascii file and load it into a string variable + type(string_type) function getfile(fileName,err,delete) result(file) + character(*), intent(in) :: fileName + type(state_type), optional, intent(out) :: err + !> [optional] delete file after reading + logical, optional, intent(in) :: delete + + type(state_type) :: err0 + integer, parameter :: buffer_len = 65536 + character(len=:), allocatable :: buffer,fileString + character(len=512) :: iomsg + integer :: lun,iostat + integer(8) :: mypos,oldpos,size_read + logical :: is_present,want_deleted + + ! Initializations + file = "" + allocate(character(len=buffer_len) :: buffer) + + !> 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 + err0 = state_type('getfile',STDLIB_IO_ERROR,'File not present:',fileName) + call err0%handle(err) + return + end if + + open(newunit=lun,file=fileName, & + form='unformatted',action='read',access='stream',status='old', & + iostat=iostat,iomsg=iomsg) + if (iostat/=0) then + err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot open',fileName,'for read:',iomsg) + call err0%handle(err) + return + end if + + allocate(character(len=0)::fileString) + read_by_chunks: do + + ! Read another buffer + inquire(unit=lun,pos=oldpos) + + read (lun, iostat=iostat, iomsg=iomsg) buffer + + if (is_iostat_end(iostat) .or. is_iostat_eor(iostat)) then + ! Partial buffer read + inquire(unit=lun,pos=mypos) + size_read = mypos-oldpos + fileString = fileString // buffer(:size_read) + iostat = 0 + iomsg = '' + exit read_by_chunks + else if (iostat == 0) then + ! Full buffer read + fileString = fileString // buffer + else + ! Read error + err0 = state_type('getfile',STDLIB_IO_ERROR,'Error reading',fileName,'at character',oldpos) + exit read_by_chunks + end if + end do read_by_chunks + + if (want_deleted) then + close(lun,iostat=iostat,status='delete') + if (iostat/=0) err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot delete',fileName,'after reading') + else + close(lun,iostat=iostat) + if (iostat/=0) err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot close',fileName,'after reading') + endif + + ! Process output + call move(from=fileString,to=file) + call err0%handle(err) + + end function getfile + end module stdlib_io From 5ca70964f2968da541434263b3838d5a547f1d6b Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 03:55:08 -0600 Subject: [PATCH 10/27] system: implement `run`, `null_device` --- src/stdlib_system.F90 | 85 ++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 79 insertions(+), 6 deletions(-) diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index f65eb200b..715a4a788 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -1,9 +1,18 @@ module stdlib_system use, intrinsic :: iso_c_binding, only : c_int, c_long +use stdlib_string_type, only: string_type, assignment(=) +use stdlib_io, only: getfile +use stdlib_error, only: error_stop, state_type implicit none private public :: sleep +!! Sub-processing +public :: run + + +public :: null_device + !! OS type inquiry public :: OS_NAME public :: OS_TYPE @@ -58,7 +67,7 @@ subroutine sleep(millisec) #else !! Linux, Unix, MacOS, MSYS2, ... ierr = usleep(int(millisec * 1000, c_int)) -if (ierr/=0) error stop 'problem with usleep() system call' +if (ierr/=0) call error_stop('problem with usleep() system call') #endif @@ -66,15 +75,23 @@ end subroutine sleep !> Determine the current OS type integer function OS_TYPE() result(os) - if (have_os) then - os = OS_CURRENT - else + if (.not.have_os) then OS_CURRENT = runtime_os() - have_os = .true. - os = OS_CURRENT + have_os = .true. end if + os = OS_CURRENT end function OS_TYPE +!> Return the file path of the null device. +function null_device() + character(:), allocatable :: null_device + if (OS_TYPE()==OS_WINDOWS) then + null_device = 'NUL' + else + null_device = '/dev/null' + end if +end function null_device + !> Determine the current OS type at runtime integer function runtime_os() result(os) !! @@ -190,4 +207,60 @@ pure function OS_NAME(os) end select end function OS_NAME +! Run a syncronous command +subroutine run(cmd,exit_state,command_state,stdout,stderr) + character(len=*), intent(in) :: cmd + integer, intent(out), optional :: exit_state,command_state + type(string_type), optional, intent(out) :: stdout + type(string_type), optional, intent(out) :: stderr + + character(len=4096) :: iomsg + type(state_type) :: err + logical :: want_stdout, want_stderr + character(:), allocatable :: redirect_file + integer :: cstat, estat, fh, iostat + + want_stdout = present(stdout) + want_stderr = present(stderr) + + if (want_stdout) then + ! Redirect output to a file + redirect_file = scratch_name() + else + redirect_file = null_device() + endif + + ! Execute command + call execute_command_line(cmd//" >"//redirect_file//" 2>&1", wait = .true., exitstat=estat,cmdstat=cstat,cmdmsg=iomsg) + + ! Retrieve stdout, stderr + if (want_stdout) stdout = getfile(redirect_file,delete=.true.) + if (want_stderr) stderr = trim(iomsg) + + if (present(exit_state)) then + exit_state = estat + elseif (estat /= 0) then + call error_stop('Cannot run: '//cmd) + end if + + if (present(command_state)) then + command_state = cstat + elseif (cstat /= 0) then + call error_stop('Command error: '//cmd) + endif + + contains + + ! Simple timestamp-based temporary name generation + function scratch_name() result(temp_filename) + character(:), allocatable :: temp_filename + character(len=10) :: timestamp,yyyymmdd + + call date_and_time(date=yyyymmdd,time=timestamp) + + temp_filename = 'tmp_' // yyyymmdd(1:8) //'_'// timestamp(1:6) // '_' // timestamp(8:10) // '.tmp' + end function scratch_name + +end subroutine run + end module stdlib_system From 3006ca5d2751254a382fda9951aeaf07aa8bfec7 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 03:55:23 -0600 Subject: [PATCH 11/27] filesystem: implement `is_directory`, `delete_file` --- src/stdlib_io_filesystem.F90 | 68 +++++++----------------------------- 1 file changed, 12 insertions(+), 56 deletions(-) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index 734ef0dc1..ba7366c91 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -4,7 +4,7 @@ module stdlib_io_filesystem use stdlib_string_type, only: string_type use stdlib_error, only: state_type, STDLIB_FS_ERROR - use stdlib_system, only: OS_TYPE + use stdlib_system, only: run, OS_TYPE, OS_UNKNOWN, OS_MACOS, OS_LINUX, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS implicit none private @@ -17,18 +17,22 @@ module stdlib_io_filesystem logical function is_directory(path) character(*), intent(in) :: path - integer :: ios + integer :: stat - - select case (get_os_type()) + select case (OS_TYPE()) case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - call execute_command_line("test -d " // dir, & - & exitstat=stat,echo=.false.,verbose=.false.) + + call run("test -d " // path, exit_state=stat) case (OS_WINDOWS) - call run('cmd /c "if not exist ' // windows_path(dir) // '\ exit /B 1"', & - & exitstat=stat,echo=.false.,verbose=.false.) + + call run('cmd /c "if not exist ' // windows_path(path) // '\ exit /B 1"', exit_state=stat) + + case default + + ! Unknown/invalid OS + stat = -1 end select @@ -36,7 +40,6 @@ logical function is_directory(path) end function is_directory - subroutine delete_file(filename, err) character(*), intent(in) :: filename type(state_type), optional, intent(out) :: err @@ -79,53 +82,6 @@ subroutine delete_file(filename, err) end if end subroutine delete_file - ! Run a command - subroutine run(cmd,exitstat,cmdstat,cmdmsg,screen_output) - character(len=*), intent(in) :: cmd - integer, intent(out), optional :: exitstat,cmdstat - character(*), optional, intent(out) :: cmdmsg - type(string_type), optional, intent(out) :: screen_output - - character(len=256) :: iomsg - logical :: want_output - character(:), allocatable :: redirect_str,redirect_file - integer :: cstat, stat, fh, iostat - - want_output = present(screen_output) - - if (want_output) then - - ! Redirect output to a file - redirect_file = scratch_name() - redirect_str = ">"//redirect_file//" 2>&1" - - else - ! No redirection and non-verbose output - if (os_is_unix()) then - redirect_str = " >/dev/null 2>&1" - else - redirect_str = " >NUL 2>&1" - end if - - end if - - call execute_command_line(cmd//redirect_str, exitstat=stat,cmdstat=cstat,cmdmsg=iomsg) - - if (want_output) then - call screen_output%read_ascii_file(redirect_file,iostat=iostat,iomsg=iomsg,delete=.true.) - end if - - if (present(exitstat)) then - exitstat = stat - elseif (stat /= 0) then - error stop 'Cannot run '//cmd - end if - - if (present(cmdstat)) cmdstat = cstat - if (present(cmdmsg)) cmdmsg = iomsg - - end subroutine run - !> Replace file system separators for windows function windows_path(path) result(winpath) From 09cf636ff5439548472bddb0c91447420e22f480 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 03:57:16 -0600 Subject: [PATCH 12/27] reorganize `delete_file` --- src/stdlib_io_filesystem.F90 | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index ba7366c91..b2c238d6f 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -9,6 +9,7 @@ module stdlib_io_filesystem private public :: delete_file + public :: is_directory contains @@ -40,8 +41,8 @@ logical function is_directory(path) end function is_directory - subroutine delete_file(filename, err) - character(*), intent(in) :: filename + subroutine delete_file(path, err) + character(*), intent(in) :: path type(state_type), optional, intent(out) :: err !> Local variables @@ -50,25 +51,19 @@ subroutine delete_file(filename, err) character(len=512) :: msg logical :: file_exists - ! Check if the filename is a file or a directory by inquiring about its existence - inquire(file=filename, exist=file_exists) + ! Check if the path exists + inquire(file=path, exist=file_exists) if (.not. file_exists) then ! File does not exist, return error status - err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,': file does not exist') + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,': file does not exist') call err0%handle(err) return endif - ! Try opening the file in "readwrite" mode to verify it is a file, not a directory - ! Because we're trying to delete the file, we need write access anyways. This will - ! be forbidden if this is a directory - open(newunit=file_unit, file=filename, status="old", action="readwrite", iostat=ios, iomsg=msg) - - print *, 'IOS ',ios,' IOMSG ',trim(msg) - - if (ios /= 0) then + ! Verify the file is not a directory + if (is_directory(path)) then ! If unable to open, assume it's a directory or inaccessible - err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,'-',msg) + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'- is a directory') call err0%handle(err) return end if @@ -76,7 +71,7 @@ subroutine delete_file(filename, err) ! Close and delete the file close(unit=file_unit, status="delete", iostat=ios, iomsg=msg) if (ios /= 0) then - err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',filename,'-',msg) + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg) call err0%handle(err) return end if From 0b26aee0deb299a8300ba59513cd484b002d1bd1 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 04:06:43 -0600 Subject: [PATCH 13/27] document `run` --- doc/specs/index.md | 1 + doc/specs/stdlib_system.md | 65 ++++++++++++++++++++++++++++++++++++++ src/stdlib_system.F90 | 31 +++++++++++++++--- 3 files changed, 93 insertions(+), 4 deletions(-) create mode 100644 doc/specs/stdlib_system.md diff --git a/doc/specs/index.md b/doc/specs/index.md index de3eb8f38..6057fd848 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -37,6 +37,7 @@ This is an index/directory of the specifications (specs) for each new module/fea - [string\_type](./stdlib_string_type.html) - Basic string support - [stringlist_type](./stdlib_stringlist_type.html) - 1-Dimensional list of strings - [strings](./stdlib_strings.html) - String handling and manipulation routines + - [system](./stdlib_system.html) - OS and sub-processing routines - [version](./stdlib_version.html) - Version information ## Released/Stable Features & Modules diff --git a/doc/specs/stdlib_system.md b/doc/specs/stdlib_system.md new file mode 100644 index 000000000..b97cc7bf1 --- /dev/null +++ b/doc/specs/stdlib_system.md @@ -0,0 +1,65 @@ +--- +title: system +--- + +# System and sub-processing module + +[TOC] + +## `run` - Execute a synchronous command + +### Status + +Experimental + +### Description + +This subroutine executes a command in the system shell synchronously, waiting for its completion before returning. It provides the option to capture the command's standard output (`stdout`) and standard error (`stderr`), along with its exit and command states. + +The implementation relies on Fortran's `execute_command_line`. + +### Syntax + +`call [[stdlib_system(module):run(subroutine)]](cmd [, exit_state] [, command_state] [, stdout] [, stderr])` + +### Class + +Subroutine + +### Arguments + +`cmd`: Shall be a scalar `character(len=*)` input argument containing the shell command to execute. + +`exit_state` (optional): Shall be an integer `intent(out)` argument, returning the command's exit state (usually `0` on success). + +`command_state` (optional): Shall be an integer `intent(out)` argument, indicating issues with command invocation. + +`stdout` (optional): Shall be an `intent(out)` `type(string_type)` variable, capturing the command's standard output. + +`stderr` (optional): Shall be an `intent(out)` `type(string_type)` variable, capturing the command's standard error messages. + +### Return Values + +- Captures the exit state and command state of the executed command. +- Retrieves `stdout` and/or `stderr` if the respective optional arguments are provided. +- Raises an error via `error stop` if no `exit_state` or `command_state` arguments are provided and an issue occurs. + +### Example + +```fortran +program example_run + use stdlib_system, only: run + implicit none + type(string_type) :: output, error_output + integer :: exit_status, cmd_status + + call run("ls -l", exit_state=exit_status, command_state=cmd_status, stdout=output, stderr=error_output) + + if (exit_status == 0) then + print *, "Command executed successfully!" + print *, "Output:", trim(output) + else + print *, "Error occurred:", trim(error_output) + end if +end program example_run +``` diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 715a4a788..454601676 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -7,7 +7,23 @@ module stdlib_system private public :: sleep -!! Sub-processing +!! version: experimental +!! +!! Executes a synchronous command in the system shell and optionally retrieves output and error messages. +!! ([Specification](../page/specs/stdlib_system.html#run-execute-a-synchronous-command)) +!! +!! ### Summary +!! Subroutine interface for running a shell command synchronously, capturing its exit and command states, +!! and optionally retrieving the command's `stdout` and `stderr`. +!! +!! ### Description +!! +!! This interface enables executing a system command with the option to retrieve outputs. The execution +!! is synchronous, meaning the calling program waits until the command completes before proceeding. +!! The command's status codes, `stdout`, and `stderr` outputs can be retrieved through optional arguments. +!! +!! @note Implementation is based on Fortran's `execute_command_line`. +!! public :: run @@ -207,13 +223,20 @@ pure function OS_NAME(os) end select end function OS_NAME -! Run a syncronous command -subroutine run(cmd,exit_state,command_state,stdout,stderr) +!> Executes a synchronous shell command and optionally retrieves its outputs. +pure subroutine run(cmd, exit_state, command_state, stdout, stderr) + !> Command to execute as a string character(len=*), intent(in) :: cmd - integer, intent(out), optional :: exit_state,command_state + !> [optional] Exit state of the command + integer, intent(out), optional :: exit_state + !> [optional] Command state, indicating issues with command invocation + integer, intent(out), optional :: command_state + !> [optional] Captured standard output (stdout) type(string_type), optional, intent(out) :: stdout + !> [optional] Captured standard error (stderr) type(string_type), optional, intent(out) :: stderr + !> Local variables character(len=4096) :: iomsg type(state_type) :: err logical :: want_stdout, want_stderr From 6cc51bbe9153a59dcb006ea258fe4bb083c3ebf9 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 04:09:45 -0600 Subject: [PATCH 14/27] document `null_device` --- doc/specs/stdlib_system.md | 45 ++++++++++++++++++++++++++++++++++++++ src/stdlib_system.F90 | 27 ++++++++++++++++++----- 2 files changed, 66 insertions(+), 6 deletions(-) diff --git a/doc/specs/stdlib_system.md b/doc/specs/stdlib_system.md index b97cc7bf1..f1a1d5e5a 100644 --- a/doc/specs/stdlib_system.md +++ b/doc/specs/stdlib_system.md @@ -63,3 +63,48 @@ program example_run end if end program example_run ``` + +## `null_device` - Return the null device file path + +### Status + +Experimental + +### Description + +This function returns the file path of the null device, which is a special file used to discard any data written to it. +It reads as an empty file. The null device's path varies by operating system: +- On Windows, the null device is represented as `NUL`. +- On UNIX-like systems (Linux, macOS), the null device is represented as `/dev/null`. + +### Syntax + +`path = [[stdlib_system(module):null_device(function)]]()` + +### Class + +Function + +### Arguments + +None. + +### Return Value + +- **Type:** `character(:), allocatable` +- Returns the null device file path as a character string, appropriate for the operating system. + +### Example + +```fortran +program example_null_device + use stdlib_system, only: null_device + implicit none + character(:), allocatable :: null_path + + ! Retrieve the null device path + null_path = null_device() + + print *, "The null device path is: ", null_path +end program example_null_device +``` diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 454601676..47ba1df1e 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -26,7 +26,21 @@ module stdlib_system !! public :: run - +!! version: experimental +!! +!! Returns the file path of the null device, which discards all data written to it. +!! ([Specification](../page/specs/stdlib_system.html#null_device-return-the-null-device-file-path)) +!! +!! ### Summary +!! Function that provides the appropriate null device file path for the current operating system. +!! +!! ### Description +!! +!! The null device is a special file that discards all data written to it and always reads as +!! an empty file. This function returns the null device path, adapted for the operating system in use. +!! +!! On Windows, this is `NUL`. On UNIX-like systems, this is `/dev/null`. +!! public :: null_device !! OS type inquiry @@ -98,13 +112,14 @@ integer function OS_TYPE() result(os) os = OS_CURRENT end function OS_TYPE -!> Return the file path of the null device. -function null_device() - character(:), allocatable :: null_device +!> Returns the file path of the null device for the current operating system. +pure function null_device() result(path) + !> File path of the null device + character(:), allocatable :: path if (OS_TYPE()==OS_WINDOWS) then - null_device = 'NUL' + path = 'NUL' else - null_device = '/dev/null' + path = '/dev/null' end if end function null_device From 551d23870db8e5b8e877724eee8e32682f689e18 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 04:15:48 -0600 Subject: [PATCH 15/27] document `OS_TYPE`, `runtime_os` --- doc/specs/stdlib_system.md | 109 +++++++++++++++++++++++++++++++++++++ src/stdlib_system.F90 | 66 +++++++++++++++++----- 2 files changed, 160 insertions(+), 15 deletions(-) diff --git a/doc/specs/stdlib_system.md b/doc/specs/stdlib_system.md index f1a1d5e5a..adbc2c647 100644 --- a/doc/specs/stdlib_system.md +++ b/doc/specs/stdlib_system.md @@ -108,3 +108,112 @@ program example_null_device print *, "The null device path is: ", null_path end program example_null_device ``` + +## `runtime_os` - Determine the OS type at runtime + +### Status + +Experimental + +### Description + +`runtime_os` inspects the runtime environment to identify the current OS type. It evaluates environment variables (`OSTYPE`, `OS`) and checks for specific files associated with known operating systems. +The supported OS types are: + +- **Linux** (`OS_LINUX`) +- **macOS** (`OS_MACOS`) +- **Windows** (`OS_WINDOWS`) +- **Cygwin** (`OS_CYGWIN`) +- **Solaris** (`OS_SOLARIS`) +- **FreeBSD** (`OS_FREEBSD`) +- **OpenBSD** (`OS_OPENBSD`) + +If the OS cannot be identified, the function returns `OS_UNKNOWN`. + +### Syntax + +`os = [[stdlib_system(module):runtime_os(function)]]()` + +### Class + +Function + +### Arguments + +None. + +### Return Value + +- **Type:** `integer` +- Returns a constant representing the OS type, or `OS_UNKNOWN` if undetermined. + +### Example + +```fortran +program example_os_detection + use stdlib_system, only: OS_TYPE, runtime_os + implicit none + integer :: os_type_cached, os_type_runtime + + ! Cached OS detection + os_type_cached = OS_TYPE() + print *, "Cached OS Type: ", os_type_cached + + ! Runtime OS detection (full inspection) + os_type_runtime = runtime_os() + print *, "Runtime OS Type: ", os_type_runtime +end program example_os_detection +``` + +--- + +## `OS_TYPE` - Cached OS type retrieval + +### Status + +Experimental + +### Description + +`OS_TYPE` provides a cached result of the `runtime_os` function. The OS type is determined during the first invocation and stored in a static variable. +Subsequent calls reuse the cached value, making this function highly efficient. + +This caching mechanism ensures negligible overhead for repeated calls, unlike `runtime_os`, which performs a full runtime inspection. + +### Syntax + +`os = [[stdlib_system(module):OS_TYPE(function)]]()` + +### Class + +Function + +### Arguments + +None. + +### Return Value + +- **Type:** `integer` +- Returns a cached constant representing the OS type, as determined by `runtime_os`. + +--- + +### Example + +```fortran +program example_os_detection + use stdlib_system, only: OS_TYPE, runtime_os + implicit none + integer :: os_type_cached, os_type_runtime + + ! Cached OS detection + os_type_cached = OS_TYPE() + print *, "Cached OS Type: ", os_type_cached + + ! Runtime OS detection (full inspection) + os_type_runtime = runtime_os() + print *, "Runtime OS Type: ", os_type_runtime +end program example_os_detection +``` + diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 47ba1df1e..919851c72 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -43,11 +43,47 @@ module stdlib_system !! public :: null_device -!! OS type inquiry - public :: OS_NAME - public :: OS_TYPE - +!! version: experimental +!! +!! Cached OS type retrieval with negligible runtime overhead. +!! ([Specification](../page/specs/stdlib_system.html#os_type-cached-os-type-retrieval)) +!! +!! ### Summary +!! Provides a cached value for the runtime OS type. +!! +!! ### Description +!! +!! This function caches the result of `runtime_os` after the first invocation. +!! Subsequent calls return the cached value, ensuring minimal overhead. +!! +public :: OS_TYPE + +!! version: experimental +!! +!! Determine the current operating system (OS) type at runtime. +!! ([Specification](../page/specs/stdlib_system.html#runtime_os-determine-the-os-type-at-runtime)) +!! +!! ### Summary +!! This function inspects the runtime environment to identify the OS type. +!! +!! ### Description +!! +!! The function evaluates environment variables (`OSTYPE` or `OS`) and filesystem attributes +!! to identify the OS. It distinguishes between several common operating systems: +!! - Linux +!! - macOS +!! - Windows +!! - Cygwin +!! - Solaris +!! - FreeBSD +!! - OpenBSD +!! +!! Returns a constant representing the OS type or `OS_UNKNOWN` if the OS cannot be determined. +!! +public :: runtime_os + !! Public parameters defining known OS types + public :: OS_NAME integer, parameter, public :: OS_UNKNOWN = 0 integer, parameter, public :: OS_LINUX = 1 integer, parameter, public :: OS_MACOS = 2 @@ -103,8 +139,10 @@ subroutine sleep(millisec) end subroutine sleep -!> Determine the current OS type -integer function OS_TYPE() result(os) +!> Retrieves the cached OS type for minimal runtime overhead. +pure integer function OS_TYPE() result(os) + !! This function uses a static cache to avoid recalculating the OS type after the first call. + !! It is recommended for performance-sensitive use cases where the OS type is checked multiple times. if (.not.have_os) then OS_CURRENT = runtime_os() have_os = .true. @@ -123,18 +161,16 @@ pure function null_device() result(path) end if end function null_device -!> Determine the current OS type at runtime integer function runtime_os() result(os) + !! The function identifies the OS by inspecting environment variables and filesystem attributes. !! - !! Returns one of OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_WINDOWS, OS_CYGWIN, - !! OS_SOLARIS, OS_FREEBSD, OS_OPENBSD. + !! ### Returns: + !! - **OS_UNKNOWN**: If the OS cannot be determined. + !! - **OS_LINUX**, **OS_MACOS**, **OS_WINDOWS**, **OS_CYGWIN**, **OS_SOLARIS**, **OS_FREEBSD**, or **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. + !! Note: This function performs a detailed runtime inspection, so it has non-negligible overhead. + + ! Local variables character(len=255) :: val integer :: length, rc logical :: file_exists From 087955a7c40ade9e02c2e051340e4bb3986e60f9 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 04:17:53 -0600 Subject: [PATCH 16/27] document OS type flags --- src/stdlib_system.F90 | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 919851c72..f92489fc1 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -82,16 +82,30 @@ module stdlib_system !! public :: runtime_os -!! Public parameters defining known OS types - public :: OS_NAME -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 +!> Version: experimental +!> +!> Integer constants representing known operating system (OS) types +!> ([Specification](../page/specs/stdlib_system.html)) +integer, parameter, public :: & + !> Represents an unknown operating system + OS_UNKNOWN = 0, & + !> Represents a Linux operating system + OS_LINUX = 1, & + !> Represents a macOS operating system + OS_MACOS = 2, & + !> Represents a Windows operating system + OS_WINDOWS = 3, & + !> Represents a Cygwin environment + OS_CYGWIN = 4, & + !> Represents a Solaris operating system + OS_SOLARIS = 5, & + !> Represents a FreeBSD operating system + OS_FREEBSD = 6, & + !> Represents an OpenBSD operating system + OS_OPENBSD = 7 + +!! Helper function returning the name of an OS parameter +public :: OS_NAME !! Static storage for the current OS logical :: have_os = .false. From f65fcd1046e9d3f71414e9bc4cc03ef97f114d5f Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 04:24:55 -0600 Subject: [PATCH 17/27] document `getfile` --- doc/specs/stdlib_io.md | 53 ++++++++++++++++++++++++++++++++++++++++++ src/stdlib_io.fypp | 32 +++++++++++++++++++++---- 2 files changed, 81 insertions(+), 4 deletions(-) diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 8c868802a..3ddd771ca 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -260,3 +260,56 @@ Provides formats for all kinds as defined in the `stdlib_kinds` module. ```fortran {!example/io/example_fmt_constants.f90!} ``` + +## `getfile` - Read a whole ASCII file into a string variable + +### Status + +Experimental + +### Description + +This function reads the entirety of a specified ASCII file and returns its content as a string. The function provides an optional error-handling mechanism via the `state_type` class. If the `err` argument is not provided, exceptions will trigger an `error stop`. The function also supports an optional flag to delete the file after reading. + +### Syntax + +`call [[stdlib_io(module):getfile(interface)]] (fileName [, err] [, delete])` + +### Class +Function + +### Arguments + +`fileName`: Shall be a character input containing the path to the ASCII file to read. It is an `intent(in)` argument. + +`err` (optional): Shall be a `type(state_type)` variable. It is an `intent(out)` argument used for error handling. + +`delete` (optional): Shall be a `logical` flag. If `.true.`, the file is deleted after reading. Default is `.false.`. It is an `intent(in)` argument. + +### Return values + +The function returns a `string_type` variable containing the full content of the specified file. + +Raises `STDLIB_IO_ERROR` if the file is not found, cannot be opened, read, or deleted. +Exceptions trigger an `error stop` unless the optional `err` argument is provided. + +### Example + +```fortran +program example_getfile + use stdlib_io + implicit none + + type(string_type) :: fileContent + type(state_type) :: err + + ! Read a file into a string + fileContent = getfile("example.txt", err=err) + + if (err%error()) then + print *, "Error reading file:", err%print() + else + print *, "File content:", fileContent + end if +end program example_getfile +``` diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index 825b86845..8e1491a4b 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -16,7 +16,27 @@ module stdlib_io implicit none private ! Public API - public :: loadtxt, savetxt, open, getline, getfile + public :: loadtxt, savetxt, open, getline + + !! version: experimental + !! + !! Reads a whole ASCII file and loads its contents into a string variable. + !! ([Specification](../page/specs/stdlib_io.html#getfile-read-a-whole-ascii-file-into-a-string-variable)) + !! + !!### Summary + !! Function interface for reading the content of a file into a string. + !! + !!### Description + !! + !! This function 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`. + !! + public :: getfile + ! Private API that is exposed so that we can test it in tests public :: parse_mode @@ -526,13 +546,17 @@ contains !> Version: experimental !> - !> Read a whole ascii file and load it into a string variable + !> 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. type(string_type) function getfile(fileName,err,delete) result(file) + !> Input file name character(*), intent(in) :: fileName + !> [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 + !> [optional] Delete file after reading? Default: do not delete logical, optional, intent(in) :: delete - + + ! Local variables type(state_type) :: err0 integer, parameter :: buffer_len = 65536 character(len=:), allocatable :: buffer,fileString From a3df034d352783070c0c4875305230a607810919 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 07:09:19 -0600 Subject: [PATCH 18/27] document `delete_file`, `is_directory` --- doc/specs/stdlib_io.md | 105 +++++++++++++++++++++++++++++++++++ src/stdlib_io_filesystem.F90 | 38 +++++++++++-- 2 files changed, 139 insertions(+), 4 deletions(-) diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 3ddd771ca..1be34855a 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -313,3 +313,108 @@ program example_getfile end if end program example_getfile ``` + +## `is_directory` - Test if a path is a directory + +### Status + +Experimental + +### Description + +This function checks if a specified file system path is a directory. It is designed to work across multiple platforms without relying on external C libraries, using system commands native to the detected operating system. + +Supported operating systems include Linux, macOS, Windows, and UNIX-like environments (e.g., FreeBSD, OpenBSD). If the operating system is unknown or unsupported, the function will return `.false.`. + +### Syntax + +`result = [[stdlib_io(module):is_directory(function)]] (path)` + +### Class +Function + +### Arguments + +`path`: Shall be a character string containing the file system path to evaluate. It is an `intent(in)` argument. + +### Return values + +The function returns a `logical` value: + +- `.true.` if the path matches an existing directory. +- `.false.` otherwise, or if the operating system is unsupported. + +### Example + +```fortran +program example_is_directory + use stdlib_io + implicit none + + logical :: isDir + + ! Test a directory path + isDir = is_directory("/path/to/check") + + if (isDir) then + print *, "The specified path is a directory." + else + print *, "The specified path is not a directory." + end if +end program example_is_directory +``` + +## `delete_file` - Delete a file + +### Status + +Experimental + +### Description + +This subroutine deletes a specified file from the filesystem. It ensures that the file exists and is not a directory before attempting deletion. +If the file cannot be deleted due to permissions, being a directory, or other issues, an error is raised. +Errors are handled using the library's `state_type`. If the optional `err` argument is not provided, exceptions trigger an `error stop`. + +### Syntax + +`call [[stdlib_fs(module):delete_file(subroutine)]] (path [, err])` + +### Class +Subroutine + +### Arguments + +`path`: Shall be a character string containing the path to the file to be deleted. It is an `intent(in)` argument. + +`err` (optional): Shall be a `type(state_type)` variable for error handling. If provided, errors are returned as a state object. If not provided, the program stops execution on error. + +### Behavior + +- Checks if the file exists. If not, an error is raised. +- Ensures the path is not a directory before deletion. +- Attempts to delete the file, raising an error if unsuccessful. + +### Return values + +The file is removed from the filesystem if the operation is successful. If the operation fails, an error is raised. + +### Example + +```fortran +program example_delete_file + use stdlib_fs + implicit none + + type(state_type) :: err + + ! Delete a file with error handling + call delete_file("example.txt", err) + + if (err%is_error) then + print *, "Failed to delete file:", err%message + else + print *, "File deleted successfully." + end if +end program example_delete_file +``` diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index b2c238d6f..bcb3d19c6 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -8,15 +8,45 @@ module stdlib_io_filesystem implicit none private + !! version: experimental + !! + !! Deletes a specified file from the filesystem. + !! ([Specification](../page/specs/stdlib_io.html#delete_file-delete-a-file)) + !! + !!### Summary + !! Subroutine to safely delete a file from the filesystem. It handles errors gracefully using the library's `state_type`. + !! + !!### Description + !! + !! This subroutine deletes a specified file. If the file does not exist, or if it is a directory or inaccessible, + !! an error is raised. Errors are handled using the library's `state_type` mechanism. If the optional `err` argument + !! is not provided, exceptions trigger an `error stop`. + !! public :: delete_file + + !! version: experimental + !! + !! Tests if a given path matches an existing directory. + !! ([Specification](../page/specs/stdlib_io.html#is_directory-test-if-a-path-is-a-directory)) + !! + !!### Summary + !! Function to evaluate whether a specified path corresponds to an existing directory. + !! + !!### Description + !! + !! This function checks if a given file system path is a directory. It is cross-platform and avoids reliance + !! on external C libraries by utilizing system calls. It supports common operating systems such as Linux, macOS, + !! Windows, and various UNIX-like environments. On unsupported operating systems, the function will return `.false.`. + !! public :: is_directory contains - !> test if a name matches an existing directory path. - !> Cross-platform version that does not use C externals - logical function is_directory(path) - character(*), intent(in) :: path + !! Tests if a given path matches an existing directory. + !! Cross-platform implementation without using external C libraries. + pure logical function is_directory(path) + !> Input path to evaluate + character(*), intent(in) :: path integer :: stat From 27d6b15e40670272ebec1678539bb8ac725b34f3 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 07:18:16 -0600 Subject: [PATCH 19/27] remove `pure` --- src/stdlib_io_filesystem.F90 | 10 +++++----- src/stdlib_system.F90 | 6 +++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index bcb3d19c6..d02b85dd8 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -42,11 +42,11 @@ module stdlib_io_filesystem contains - !! Tests if a given path matches an existing directory. - !! Cross-platform implementation without using external C libraries. - pure logical function is_directory(path) - !> Input path to evaluate - character(*), intent(in) :: path + !! Tests if a given path matches an existing directory. + !! Cross-platform implementation without using external C libraries. + logical function is_directory(path) + !> Input path to evaluate + character(*), intent(in) :: path integer :: stat diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index f92489fc1..76daf0bba 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -154,7 +154,7 @@ subroutine sleep(millisec) end subroutine sleep !> Retrieves the cached OS type for minimal runtime overhead. -pure integer function OS_TYPE() result(os) +integer function OS_TYPE() result(os) !! This function uses a static cache to avoid recalculating the OS type after the first call. !! It is recommended for performance-sensitive use cases where the OS type is checked multiple times. if (.not.have_os) then @@ -165,7 +165,7 @@ pure integer function OS_TYPE() result(os) end function OS_TYPE !> Returns the file path of the null device for the current operating system. -pure function null_device() result(path) +function null_device() result(path) !> File path of the null device character(:), allocatable :: path if (OS_TYPE()==OS_WINDOWS) then @@ -289,7 +289,7 @@ pure function OS_NAME(os) end function OS_NAME !> Executes a synchronous shell command and optionally retrieves its outputs. -pure subroutine run(cmd, exit_state, command_state, stdout, stderr) +subroutine run(cmd, exit_state, command_state, stdout, stderr) !> Command to execute as a string character(len=*), intent(in) :: cmd !> [optional] Exit state of the command From 283ae756ca58ee7b14a9755671ca95b3f10d1b53 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 07:55:17 -0600 Subject: [PATCH 20/27] use Windows API --- src/stdlib_io_filesystem.F90 | 45 ++++++++++++++++++++++++++++++------ src/stdlib_system.F90 | 1 + test/io/existing_file.txt | 0 test/io/test_filesystem.f90 | 31 +++++++++++++++++++++++-- 4 files changed, 68 insertions(+), 9 deletions(-) create mode 100644 test/io/existing_file.txt diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index d02b85dd8..52722ca0b 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -2,9 +2,10 @@ !> Interaction with the filesystem. module stdlib_io_filesystem - use stdlib_string_type, only: string_type + use stdlib_string_type, only: string_type,write(formatted) use stdlib_error, only: state_type, STDLIB_FS_ERROR use stdlib_system, only: run, OS_TYPE, OS_UNKNOWN, OS_MACOS, OS_LINUX, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS + use iso_c_binding, only: c_char, c_int, c_null_char implicit none private @@ -48,18 +49,36 @@ logical function is_directory(path) !> Input path to evaluate character(*), intent(in) :: path - integer :: stat + integer :: stat,cstat + type(string_type) :: stdout,stderr + + ! Windows API interface + integer(c_int) :: attrs + integer(c_int), parameter :: FILE_ATTRIBUTE_DIRECTORY = int(z'10',c_int) + + interface + ! Declare the GetFileAttributesA function from kernel32.dll + integer(c_int) function GetFileAttributesA(lpFileName) bind(c, name="GetFileAttributesA") + import c_int, c_char + character(kind=c_char), dimension(*), intent(in) :: lpFileName + end function GetFileAttributesA + end interface select case (OS_TYPE()) case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - call run("test -d " // path, exit_state=stat) + call run("test -d " // trim(path), exit_state=stat, command_state=cstat, stdout=stdout,stderr=stderr) case (OS_WINDOWS) - call run('cmd /c "if not exist ' // windows_path(path) // '\ exit /B 1"', exit_state=stat) - + attrs = GetFileAttributesA(c_path(windows_path(path))) + + print *, 'ATTRS = ',attrs + + is_directory = attrs /= -1 & ! attributes received + .and. btest(attrs,FILE_ATTRIBUTE_DIRECTORY) ! is directory + case default ! Unknown/invalid OS @@ -111,11 +130,11 @@ end subroutine delete_file function windows_path(path) result(winpath) character(*), intent(in) :: path - character(len(path)) :: winpath + character(len_trim(path)) :: winpath integer :: idx - winpath = path + winpath = trim(path) idx = index(winpath,'/') do while(idx > 0) winpath(idx:idx) = '\' @@ -123,5 +142,17 @@ function windows_path(path) result(winpath) end do end function windows_path + + !> Get a C path + function c_path(path) + character(*), intent(in) :: path + character(c_char) :: c_path(len(path)+1) + + integer :: i + + forall(i=1:len(path)) c_path(i) = path(i:i) + c_path(len(path)+1) = c_null_char + + end function c_path end module stdlib_io_filesystem diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 76daf0bba..b5c9de88f 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -310,6 +310,7 @@ subroutine run(cmd, exit_state, command_state, stdout, stderr) want_stdout = present(stdout) want_stderr = present(stderr) + iomsg = repeat(' ',4096) if (want_stdout) then ! Redirect output to a file diff --git a/test/io/existing_file.txt b/test/io/existing_file.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 index 47ff474a8..6e47711da 100644 --- a/test/io/test_filesystem.f90 +++ b/test/io/test_filesystem.f90 @@ -32,7 +32,7 @@ subroutine test_delete_file_non_existent(error) type(state_type) :: state ! Attempt to delete a file that doesn't exist - call delete_file('non_existent_file_blurp.txt', state) + call delete_file('non_existent_file.txt', state) call check(error, state%error(), 'Error should be triggered for non-existent file') if (allocated(error)) return @@ -61,7 +61,7 @@ subroutine test_delete_file_existing(error) call delete_file(filename, state) ! Check deletion successful - call check(error, state%ok(), state%print()) + call check(error, state%ok(), 'delete_file returned '//state%print()) if (allocated(error)) return ! Check if the file was successfully deleted (should no longer exist) @@ -83,11 +83,13 @@ subroutine test_delete_directory(error) filename = 'test_directory' ! The directory is not nested: it should be cross-platform to just call `mkdir` + print *, 'mkdir' call execute_command_line('mkdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) call check(error, ios==0 .and. iocmd==0, 'Cannot init delete_directory test: '//trim(msg)) if (allocated(error)) return ! Attempt to delete a directory (which should fail) + print *, 'dfelete' call delete_file(filename, state) ! Check that an error was raised since the target is a directory @@ -95,12 +97,37 @@ subroutine test_delete_directory(error) if (allocated(error)) return ! Clean up: remove the empty directory + print *, 'rmdir' call execute_command_line('rmdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup delete_directory test: '//trim(msg)) if (allocated(error)) return end subroutine test_delete_directory + ! Test `is_directory` for a directory + subroutine test_is_directory_dir(error) + type(error_type), allocatable, intent(out) :: error + character(len=256) :: dirname + logical :: result + integer :: ios, iocmd + character(len=512) :: msg + + dirname = "test_dir" + + ! Create a directory + call execute_command_line("mkdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios == 0 .and. iocmd == 0, "Cannot create test directory: " // trim(msg)) + if (allocated(error)) return + + ! Verify `is_directory` identifies it as a directory + result = is_directory(dirname) + call check(error, result, "is_directory did not recognize a valid directory") + if (allocated(error)) return + + ! Clean up: remove the directory + call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios == 0 .and. iocmd == 0, "Cannot remove test directory: " // trim(msg)) + end subroutine test_is_directory_dir end module test_filesystem From 3990315f5293fc95c000e7ba2ea72b26c0dd0cf0 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 07:55:17 -0600 Subject: [PATCH 21/27] Use Windows API if possible --- src/stdlib_io_filesystem.F90 | 46 +++++++++++++++++++++++++++++++----- src/stdlib_system.F90 | 1 + test/io/existing_file.txt | 0 test/io/test_filesystem.f90 | 31 ++++++++++++++++++++++-- 4 files changed, 70 insertions(+), 8 deletions(-) create mode 100644 test/io/existing_file.txt diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index d02b85dd8..dacee54d1 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -2,9 +2,10 @@ !> Interaction with the filesystem. module stdlib_io_filesystem - use stdlib_string_type, only: string_type + use stdlib_string_type, only: string_type,write(formatted) use stdlib_error, only: state_type, STDLIB_FS_ERROR use stdlib_system, only: run, OS_TYPE, OS_UNKNOWN, OS_MACOS, OS_LINUX, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS + use iso_c_binding, only: c_char, c_int, c_null_char implicit none private @@ -48,18 +49,39 @@ logical function is_directory(path) !> Input path to evaluate character(*), intent(in) :: path - integer :: stat + integer :: stat,cstat + type(string_type) :: stdout,stderr + +#ifdef _WIN32 + ! Windows API interface + integer(c_int) :: attrs + integer(c_int), parameter :: FILE_ATTRIBUTE_DIRECTORY = int(z'10',c_int) + interface + ! Declare the GetFileAttributesA function from kernel32.dll + integer(c_int) function GetFileAttributesA(lpFileName) bind(c, name="GetFileAttributesA") + import c_int, c_char + character(kind=c_char), dimension(*), intent(in) :: lpFileName + end function GetFileAttributesA + end interface +#endif select case (OS_TYPE()) case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) - call run("test -d " // path, exit_state=stat) + call run("test -d " // trim(path), exit_state=stat, command_state=cstat, stdout=stdout,stderr=stderr) case (OS_WINDOWS) +#ifdef _WIN32 + attrs = GetFileAttributesA(c_path(windows_path(path))) + print *, 'attrs = ',attrs + stat = merge(0,-1, attrs /= -1 & ! attributes received + .and. btest(attrs,FILE_ATTRIBUTE_DIRECTORY) ! is directory +#else call run('cmd /c "if not exist ' // windows_path(path) // '\ exit /B 1"', exit_state=stat) - +#endif + case default ! Unknown/invalid OS @@ -111,11 +133,11 @@ end subroutine delete_file function windows_path(path) result(winpath) character(*), intent(in) :: path - character(len(path)) :: winpath + character(len_trim(path)) :: winpath integer :: idx - winpath = path + winpath = trim(path) idx = index(winpath,'/') do while(idx > 0) winpath(idx:idx) = '\' @@ -123,5 +145,17 @@ function windows_path(path) result(winpath) end do end function windows_path + + !> Get a C path + function c_path(path) + character(*), intent(in) :: path + character(c_char) :: c_path(len(path)+1) + + integer :: i + + forall(i=1:len(path)) c_path(i) = path(i:i) + c_path(len(path)+1) = c_null_char + + end function c_path end module stdlib_io_filesystem diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 76daf0bba..b5c9de88f 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -310,6 +310,7 @@ subroutine run(cmd, exit_state, command_state, stdout, stderr) want_stdout = present(stdout) want_stderr = present(stderr) + iomsg = repeat(' ',4096) if (want_stdout) then ! Redirect output to a file diff --git a/test/io/existing_file.txt b/test/io/existing_file.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 index 47ff474a8..6e47711da 100644 --- a/test/io/test_filesystem.f90 +++ b/test/io/test_filesystem.f90 @@ -32,7 +32,7 @@ subroutine test_delete_file_non_existent(error) type(state_type) :: state ! Attempt to delete a file that doesn't exist - call delete_file('non_existent_file_blurp.txt', state) + call delete_file('non_existent_file.txt', state) call check(error, state%error(), 'Error should be triggered for non-existent file') if (allocated(error)) return @@ -61,7 +61,7 @@ subroutine test_delete_file_existing(error) call delete_file(filename, state) ! Check deletion successful - call check(error, state%ok(), state%print()) + call check(error, state%ok(), 'delete_file returned '//state%print()) if (allocated(error)) return ! Check if the file was successfully deleted (should no longer exist) @@ -83,11 +83,13 @@ subroutine test_delete_directory(error) filename = 'test_directory' ! The directory is not nested: it should be cross-platform to just call `mkdir` + print *, 'mkdir' call execute_command_line('mkdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) call check(error, ios==0 .and. iocmd==0, 'Cannot init delete_directory test: '//trim(msg)) if (allocated(error)) return ! Attempt to delete a directory (which should fail) + print *, 'dfelete' call delete_file(filename, state) ! Check that an error was raised since the target is a directory @@ -95,12 +97,37 @@ subroutine test_delete_directory(error) if (allocated(error)) return ! Clean up: remove the empty directory + print *, 'rmdir' call execute_command_line('rmdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup delete_directory test: '//trim(msg)) if (allocated(error)) return end subroutine test_delete_directory + ! Test `is_directory` for a directory + subroutine test_is_directory_dir(error) + type(error_type), allocatable, intent(out) :: error + character(len=256) :: dirname + logical :: result + integer :: ios, iocmd + character(len=512) :: msg + + dirname = "test_dir" + + ! Create a directory + call execute_command_line("mkdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios == 0 .and. iocmd == 0, "Cannot create test directory: " // trim(msg)) + if (allocated(error)) return + + ! Verify `is_directory` identifies it as a directory + result = is_directory(dirname) + call check(error, result, "is_directory did not recognize a valid directory") + if (allocated(error)) return + + ! Clean up: remove the directory + call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios == 0 .and. iocmd == 0, "Cannot remove test directory: " // trim(msg)) + end subroutine test_is_directory_dir end module test_filesystem From 6b61ab0b4d560e5a48802794246e2554826bcd0e Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 08:17:40 -0600 Subject: [PATCH 22/27] test is_directory --- src/stdlib_io_filesystem.F90 | 15 +++++++++++---- test/io/test_filesystem.f90 | 16 ++++++---------- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 index dacee54d1..020e392a1 100644 --- a/src/stdlib_io_filesystem.F90 +++ b/src/stdlib_io_filesystem.F90 @@ -73,13 +73,14 @@ end function GetFileAttributesA case (OS_WINDOWS) -#ifdef _WIN32 +#ifdef _WIN32 + ! Use Windows API if available attrs = GetFileAttributesA(c_path(windows_path(path))) - print *, 'attrs = ',attrs stat = merge(0,-1, attrs /= -1 & ! attributes received .and. btest(attrs,FILE_ATTRIBUTE_DIRECTORY) ! is directory #else - call run('cmd /c "if not exist ' // windows_path(path) // '\ exit /B 1"', exit_state=stat) + ! Fallback to cmd.exe otherwise + call run('cmd /c "if not exist ' // windows_path(path) // '\* exit /B 1"', exit_state=stat) #endif case default @@ -121,7 +122,13 @@ subroutine delete_file(path, err) end if ! Close and delete the file - close(unit=file_unit, status="delete", iostat=ios, iomsg=msg) + open(newunit=file_unit, file=path, status='old', iostat=ios, iomsg=msg) + if (ios /= 0) then + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg) + call err0%handle(err) + return + end if + close(unit=file_unit, status='delete', iostat=ios, iomsg=msg) if (ios /= 0) then err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg) call err0%handle(err) diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 index 6e47711da..112689f9b 100644 --- a/test/io/test_filesystem.f90 +++ b/test/io/test_filesystem.f90 @@ -21,7 +21,8 @@ subroutine collect_filesystem(testsuite) testsuite = [ & new_unittest("fs_delete_non_existent", test_delete_file_non_existent), & new_unittest("fs_delete_existing_file", test_delete_file_existing), & - new_unittest("fd_delete_file_being_dir", test_delete_directory) & + new_unittest("fs_delete_file_being_dir", test_delete_directory), & + new_unittest("fs_is_directory_dir", test_is_directory_dir) & ] end subroutine collect_filesystem @@ -61,7 +62,7 @@ subroutine test_delete_file_existing(error) call delete_file(filename, state) ! Check deletion successful - call check(error, state%ok(), 'delete_file returned '//state%print()) + call check(error, state%ok(), state%print()) if (allocated(error)) return ! Check if the file was successfully deleted (should no longer exist) @@ -83,21 +84,18 @@ subroutine test_delete_directory(error) filename = 'test_directory' ! The directory is not nested: it should be cross-platform to just call `mkdir` - print *, 'mkdir' call execute_command_line('mkdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) call check(error, ios==0 .and. iocmd==0, 'Cannot init delete_directory test: '//trim(msg)) if (allocated(error)) return ! Attempt to delete a directory (which should fail) - print *, 'dfelete' call delete_file(filename, state) ! Check that an error was raised since the target is a directory - call check(error, state%ok(), 'Error was not triggered trying to delete directory') + call check(error, state%error(), 'Error was not triggered trying to delete directory') if (allocated(error)) return ! Clean up: remove the empty directory - print *, 'rmdir' call execute_command_line('rmdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup delete_directory test: '//trim(msg)) if (allocated(error)) return @@ -108,11 +106,10 @@ end subroutine test_delete_directory subroutine test_is_directory_dir(error) type(error_type), allocatable, intent(out) :: error character(len=256) :: dirname - logical :: result integer :: ios, iocmd character(len=512) :: msg - dirname = "test_dir" + dirname = "this_test_dir_tmp" ! Create a directory call execute_command_line("mkdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) @@ -120,8 +117,7 @@ subroutine test_is_directory_dir(error) if (allocated(error)) return ! Verify `is_directory` identifies it as a directory - result = is_directory(dirname) - call check(error, result, "is_directory did not recognize a valid directory") + call check(error, is_directory(dirname), "is_directory did not recognize a valid directory") if (allocated(error)) return ! Clean up: remove the directory From 3c2f866541c170ff91b8dc93f709f574937fdc2d Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 08:19:08 -0600 Subject: [PATCH 23/27] test is_directory with file --- test/io/test_filesystem.f90 | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 index 112689f9b..e829456b9 100644 --- a/test/io/test_filesystem.f90 +++ b/test/io/test_filesystem.f90 @@ -22,7 +22,8 @@ subroutine collect_filesystem(testsuite) new_unittest("fs_delete_non_existent", test_delete_file_non_existent), & new_unittest("fs_delete_existing_file", test_delete_file_existing), & new_unittest("fs_delete_file_being_dir", test_delete_directory), & - new_unittest("fs_is_directory_dir", test_is_directory_dir) & + new_unittest("fs_is_directory_dir", test_is_directory_dir), & + new_unittest("fs_is_directory_file", test_is_directory_file) & ] end subroutine collect_filesystem @@ -125,6 +126,34 @@ subroutine test_is_directory_dir(error) call check(error, ios == 0 .and. iocmd == 0, "Cannot remove test directory: " // trim(msg)) end subroutine test_is_directory_dir + ! Test `is_directory` for a regular file + subroutine test_is_directory_file(error) + type(error_type), allocatable, intent(out) :: error + character(len=256) :: filename + logical :: result + integer :: ios, iunit + character(len=512) :: msg + type(state_type) :: err + + filename = "test_file.txt" + + ! Create a file + open(newunit=iunit, file=filename, status="replace", iostat=ios, iomsg=msg) + call check(error, ios == 0, "Cannot create test file: " // trim(msg)) + if (allocated(error)) return + close(iunit) + + ! Verify `is_directory` identifies it as not a directory + result = is_directory(filename) + call check(error, .not. result, "is_directory falsely recognized a regular file as a directory") + if (allocated(error)) return + + ! Clean up: remove the file + call delete_file(filename, err) + call check(error, err%ok(), err%print()) + + end subroutine test_is_directory_file + end module test_filesystem program test_all_filesystem From 8788cc606724b587a61cb5a38549efe68afd5eda Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Mon, 9 Dec 2024 08:44:18 -0600 Subject: [PATCH 24/27] fix docs --- doc/specs/stdlib_io.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 1be34855a..87bc0e495 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -273,7 +273,7 @@ This function reads the entirety of a specified ASCII file and returns its conte ### Syntax -`call [[stdlib_io(module):getfile(interface)]] (fileName [, err] [, delete])` +`call [[stdlib_io(module):getfile(function)]] (fileName [, err] [, delete=.false.])` ### Class Function @@ -411,8 +411,8 @@ program example_delete_file ! Delete a file with error handling call delete_file("example.txt", err) - if (err%is_error) then - print *, "Failed to delete file:", err%message + if (err%error()) then + print *, "Failed to delete file:", err%print() else print *, "File deleted successfully." end if From 5b2dbb0ecd1649b9d77ba5b40fecb008c72e7ab5 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 11 Dec 2024 08:41:50 +0100 Subject: [PATCH 25/27] `getfile`: read all at once --- src/stdlib_io.fypp | 73 ++++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 35 deletions(-) diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index 8e1491a4b..583f46eb0 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -558,16 +558,14 @@ contains ! Local variables type(state_type) :: err0 - integer, parameter :: buffer_len = 65536 - character(len=:), allocatable :: buffer,fileString + character(len=:), allocatable :: fileString character(len=512) :: iomsg integer :: lun,iostat - integer(8) :: mypos,oldpos,size_read + integer(int64) :: errpos,fileSize logical :: is_present,want_deleted ! Initializations file = "" - allocate(character(len=buffer_len) :: buffer) !> Check if the file should be deleted after reading if (present(delete)) then @@ -583,54 +581,59 @@ contains call err0%handle(err) return end if - + + !> Retrieve file size + inquire(file=fileName,size=fileSize) + + invalid_size: if (fileSize<0) then + + err0 = state_type('getfile',STDLIB_IO_ERROR,fileName,'has invalid size=',fileSize) + 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 err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot open',fileName,'for read:',iomsg) call err0%handle(err) return - end if - - allocate(character(len=0)::fileString) - read_by_chunks: do - - ! Read another buffer - inquire(unit=lun,pos=oldpos) - - read (lun, iostat=iostat, iomsg=iomsg) buffer - - if (is_iostat_end(iostat) .or. is_iostat_eor(iostat)) then - ! Partial buffer read - inquire(unit=lun,pos=mypos) - size_read = mypos-oldpos - fileString = fileString // buffer(:size_read) - iostat = 0 - iomsg = '' - exit read_by_chunks - else if (iostat == 0) then - ! Full buffer read - fileString = fileString // buffer - else - ! Read error - err0 = state_type('getfile',STDLIB_IO_ERROR,'Error reading',fileName,'at character',oldpos) - exit read_by_chunks - end if - end do read_by_chunks - + end if + + allocate(character(len=fileSize) :: fileString) + + read_data: if (fileSize>0) then + + read(lun, pos=1, iostat=iostat, iomsg=iomsg) fileString + + ! Read error + if (iostat/=0) then + + inquire(unit=lun,pos=errpos) + err0 = state_type('getfile',STDLIB_IO_ERROR,'Error reading',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('getfile',STDLIB_IO_ERROR,'Cannot delete',fileName,'after reading') else close(lun,iostat=iostat) if (iostat/=0) err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot close',fileName,'after reading') - endif + endif ! Process output call move(from=fileString,to=file) call err0%handle(err) - end function getfile + end function getfile end module stdlib_io From 79d6f46b268d374047a814773207b3be1eaffb42 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 11 Dec 2024 08:52:44 +0100 Subject: [PATCH 26/27] `getline` add tests --- test/io/test_getline.f90 | 81 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 78 insertions(+), 3 deletions(-) diff --git a/test/io/test_getline.f90 b/test/io/test_getline.f90 index e035a904f..df1053f0a 100644 --- a/test/io/test_getline.f90 +++ b/test/io/test_getline.f90 @@ -1,6 +1,7 @@ module test_getline - use stdlib_io, only : getline - use stdlib_string_type, only : string_type, len + use stdlib_io, only : getline, getfile + use stdlib_error, only: state_type + use stdlib_string_type, only : string_type, len, len_trim use testdrive, only : new_unittest, unittest_type, error_type, check implicit none private @@ -20,7 +21,10 @@ subroutine collect_getline(testsuite) new_unittest("pad-no", test_pad_no), & new_unittest("iostat-end", test_iostat_end), & new_unittest("closed-unit", test_closed_unit, should_fail=.true.), & - new_unittest("no-unit", test_no_unit, should_fail=.true.) & + new_unittest("no-unit", test_no_unit, should_fail=.true.), & + new_unittest("getfile-no", test_getfile_missing), & + new_unittest("getfile-empty", test_getfile_empty), & + new_unittest("getfile-non-empty", test_getfile_non_empty) & ] end subroutine collect_getline @@ -139,6 +143,77 @@ subroutine test_no_unit(error) call check(error, stat, msg) end subroutine test_no_unit + subroutine test_getfile_missing(error) + !> Test for a missing file. + type(error_type), allocatable, intent(out) :: error + + type(string_type) :: fileContents + type(state_type) :: err + + fileContents = getfile("nonexistent_file.txt", err) + + ! Check that an error was returned + call check(error, err%error(), "Error not returned on a missing file") + if (allocated(error)) return + + end subroutine test_getfile_missing + + subroutine test_getfile_empty(error) + !> Test for an empty file. + type(error_type), allocatable, intent(out) :: error + + integer :: ios + character(len=:), allocatable :: filename + type(string_type) :: fileContents + type(state_type) :: err + + ! Get a temporary file name + filename = "test_getfile_empty.txt" + + ! Create an empty file + open(newunit=ios, file=filename, action="write", form="formatted", access="sequential") + close(ios) + + ! Read and delete it + fileContents = getfile(filename, err, delete=.true.) + + call check(error, err%ok(), "Should not return error reading an empty file") + if (allocated(error)) return + + call check(error, len_trim(fileContents) == 0, "String from empty file should be empty") + if (allocated(error)) return + + end subroutine test_getfile_empty + + subroutine test_getfile_non_empty(error) + !> Test for a non-empty file. + type(error_type), allocatable, intent(out) :: error + + integer :: ios + character(len=:), allocatable :: filename + type(string_type) :: fileContents + type(state_type) :: err + + ! Get a temporary file name + filename = "test_getfile_size5.txt" + + ! Create a fixed-size file + open(newunit=ios, file=filename, action="write", form="unformatted", access="stream") + write(ios) "12345" + close(ios) + + ! Read and delete it + fileContents = getfile(filename, err, delete=.true.) + + call check(error, err%ok(), "Should not return error reading a non-empty file") + if (allocated(error)) return + + call check(error, len_trim(fileContents) == 5, "Wrong string size returned") + if (allocated(error)) return + + end subroutine test_getfile_non_empty + + end module test_getline From 5b2283dc9e7f3f0d6b897e943d59625c12768647 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 11 Dec 2024 08:55:30 +0100 Subject: [PATCH 27/27] better error message on read --- src/stdlib_io.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index 583f46eb0..2dda4eea6 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -614,7 +614,7 @@ contains if (iostat/=0) then inquire(unit=lun,pos=errpos) - err0 = state_type('getfile',STDLIB_IO_ERROR,'Error reading',fileName,'at byte',errpos) + err0 = state_type('getfile',STDLIB_IO_ERROR,iomsg,'(',fileName,'at byte',errpos,')') call err0%handle(err) return