From e66a6f0f880bae52e0eca7462b8590c555ba00c4 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Wed, 4 Feb 2026 20:49:41 +0900 Subject: [PATCH 1/6] Expose ARPACK eigen APIs; docs and formatting Update project metadata in FORDsetup (project summary and GitHub/download URLs). In ARPACK_SAUPD.F90: add author/header comments, export SAUPD_ErrorMsg, SEUPD_ErrorMsg, SymLargestEigenVal and SymSmallestEigenVal, and rename/clean up INTERFACE blocks for the symmetric eigenvalue routines (adjusted function/interface declarations and formatting). In String_Class.F90: fix continuation/indentation and alignment for alphabet constants and tidy INTERFACE continuation lines for several string routines. --- FORDsetup.md | 8 ++- src/modules/ARPACK/src/ARPACK_SAUPD.F90 | 68 +++++++++++-------------- src/modules/String/src/String_Class.F90 | 14 ++--- 3 files changed, 39 insertions(+), 51 deletions(-) diff --git a/FORDsetup.md b/FORDsetup.md index ffa9af860..a18d004bb 100644 --- a/FORDsetup.md +++ b/FORDsetup.md @@ -1,8 +1,8 @@ --- project: easifemBase -summary: easifemBase is part of easifem library, which is a framework for Expandable And Scalable Infrastructure for Finite Element Methods. -project_download: https://github.com/vickysharma0812/easifem-base -project_github: https://github.com/vickysharma0812/easifem-base +summary: easifemBase is part of easifem library, which is a platform for Expandable And Scalable Infrastructure for Finite Element Methods. +project_download: https://github.com/easifem/base +project_github: https://github.com/easifem/base project_website: https://www.easifem.com license: gfdl project_dir: ./src/modules/Utility @@ -41,5 +41,3 @@ preprocesses: true --- {!./README.md!} - - diff --git a/src/modules/ARPACK/src/ARPACK_SAUPD.F90 b/src/modules/ARPACK/src/ARPACK_SAUPD.F90 index 22340fb10..f09368a77 100644 --- a/src/modules/ARPACK/src/ARPACK_SAUPD.F90 +++ b/src/modules/ARPACK/src/ARPACK_SAUPD.F90 @@ -15,16 +15,30 @@ ! along with this program. If not, see ! +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-09 +! summary: Reverse communication interface (RCI) for the Implicitly +! Restarted Arnoldi Iteration. + MODULE ARPACK_SAUPD USE GlobalData, ONLY: I4B, DFP, LGT USE String_Class, ONLY: String IMPLICIT NONE PRIVATE +PUBLIC :: SAUPD_ErrorMsg +PUBLIC :: SEUPD_ErrorMsg +PUBLIC :: SymLargestEigenVal +PUBLIC :: SymSmallestEigenVal + !---------------------------------------------------------------------------- ! SAUPD_ErrorMsg !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-09 +! summary: error message for SAUPD + INTERFACE MODULE FUNCTION SAUPD_ErrorMsg(INFO) RESULT(ans) INTEGER(I4B), INTENT(IN) :: INFO @@ -32,12 +46,14 @@ MODULE FUNCTION SAUPD_ErrorMsg(INFO) RESULT(ans) END FUNCTION SAUPD_ErrorMsg END INTERFACE -PUBLIC :: SAUPD_ErrorMsg - !---------------------------------------------------------------------------- ! SAUPD_ErrorMsg !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2022-12-09 +! summary: error message for SEUPD + INTERFACE MODULE FUNCTION SEUPD_ErrorMsg(INFO) RESULT(ans) INTEGER(I4B), INTENT(IN) :: INFO @@ -45,8 +61,6 @@ MODULE FUNCTION SEUPD_ErrorMsg(INFO) RESULT(ans) END FUNCTION SEUPD_ErrorMsg END INTERFACE -PUBLIC :: SEUPD_ErrorMsg - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -59,10 +73,10 @@ END FUNCTION SEUPD_ErrorMsg ! !- This routine calculates the largest eigenvalue of a real sym dense matrix. !- It calls ARPACK SSAUPD or DSAUPD routine - -INTERFACE +! +INTERFACE SymLargestEigenVal MODULE FUNCTION SymLargestEigenVal1(mat, which, NCV, maxIter, tol) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: mat(:, :) !! dense matrix CHARACTER(*), OPTIONAL, INTENT(IN) :: which @@ -80,30 +94,24 @@ MODULE FUNCTION SymLargestEigenVal1(mat, which, NCV, maxIter, tol) & REAL(DFP) :: ans !! maximum eigenvalue END FUNCTION SymLargestEigenVal1 -END INTERFACE - -INTERFACE SymLargestEigenVal - MODULE PROCEDURE SymLargestEigenVal1 END INTERFACE SymLargestEigenVal -PUBLIC :: SymLargestEigenVal - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2022-12-10 -! summary: Calculate the `nev` smallest eigenvalue of a real sym dense matrix +! summary: Calculate the smallest eigenvalue of a real sym dense matrix ! !# Introduction ! !- This routine calculates the smallest eigenvalue of a real sym dense matrix. !- It calls ARPACK SSAUPD or DSAUPD routine - -INTERFACE +! +INTERFACE SymLargestEigenVal MODULE FUNCTION SymLargestEigenVal2(mat, nev, which, NCV, maxIter, tol) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: mat(:, :) !! dense matrix INTEGER(I4B), INTENT(IN) :: nev @@ -123,10 +131,6 @@ MODULE FUNCTION SymLargestEigenVal2(mat, nev, which, NCV, maxIter, tol) & REAL(DFP) :: ans(nev) !! first k, largest eigenvalue END FUNCTION SymLargestEigenVal2 -END INTERFACE - -INTERFACE SymLargestEigenVal - MODULE PROCEDURE SymLargestEigenVal2 END INTERFACE SymLargestEigenVal !---------------------------------------------------------------------------- @@ -156,9 +160,9 @@ END FUNCTION SymLargestEigenVal2 ! decomposition of mat0. !@endnote -INTERFACE +INTERFACE SymSmallestEigenVal MODULE FUNCTION SymSmallestEigenVal1(mat, sigma, which, NCV, maxIter, tol) & - & RESULT(ans) + RESULT(ans) REAL(DFP), INTENT(IN) :: mat(:, :) !! dense matrix REAL(DFP), OPTIONAL, INTENT(IN) :: sigma @@ -178,14 +182,8 @@ MODULE FUNCTION SymSmallestEigenVal1(mat, sigma, which, NCV, maxIter, tol) & REAL(DFP) :: ans !! maximum eigenvalue END FUNCTION SymSmallestEigenVal1 -END INTERFACE - -INTERFACE SymSmallestEigenVal - MODULE PROCEDURE SymSmallestEigenVal1 END INTERFACE SymSmallestEigenVal -PUBLIC :: SymSmallestEigenVal - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -205,19 +203,15 @@ END FUNCTION SymSmallestEigenVal1 ! !- [ ] TODO use Cholsky factorization instead of LU as mat is ! symmetric. -! -INTERFACE +INTERFACE SymSmallestEigenVal MODULE FUNCTION SymSmallestEigenVal2(mat, isFactor, ipiv, sigma, which, & - & NCV, maxIter, tol) & - & RESULT(ans) + NCV, maxIter, tol) RESULT(ans) REAL(DFP), INTENT(INOUT) :: mat(:, :) - !! !! Dense matrix !! If isFactor is false, then this matrix will change on return !! in this case, it will contain LU decomposition of `A-sigma*I` !! If isFactor is true, then this matrix will not change - !! LOGICAL(LGT), INTENT(INOUT) :: isFactor !! if mat is already factorized, the set isFactor to true !! if mat is not factorized, then set isFactor to false @@ -244,10 +238,6 @@ MODULE FUNCTION SymSmallestEigenVal2(mat, isFactor, ipiv, sigma, which, & REAL(DFP) :: ans !! smallest eigenvalue END FUNCTION SymSmallestEigenVal2 -END INTERFACE - -INTERFACE SymSmallestEigenVal - MODULE PROCEDURE SymSmallestEigenVal2 END INTERFACE SymSmallestEigenVal END MODULE ARPACK_SAUPD diff --git a/src/modules/String/src/String_Class.F90 b/src/modules/String/src/String_Class.F90 index cc89858e7..b962fc2ac 100644 --- a/src/modules/String/src/String_Class.F90 +++ b/src/modules/String/src/String_Class.F90 @@ -29,10 +29,10 @@ MODULE String_Class ! INTEGER, PARAMETER, PUBLIC :: CK = SELECTED_CHAR_KIND('DEFAULT') INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('DEFAULT') ! internal parameters -CHARACTER(kind=CK, len=26), PARAMETER :: UPPER_ALPHABET = & - & 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' -CHARACTER(kind=CK, len=26), PARAMETER :: LOWER_ALPHABET = & - & 'abcdefghijklmnopqrstuvwxyz' +CHARACTER(kind=CK, len=26), PARAMETER :: UPPER_ALPHABET = & + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +CHARACTER(kind=CK, len=26), PARAMETER :: LOWER_ALPHABET = & + 'abcdefghijklmnopqrstuvwxyz' CHARACTER(kind=CK, len=1), PARAMETER :: SPACE = ' ' CHARACTER(kind=CK, len=1), PARAMETER :: TAB = ACHAR(9) CHARACTER(kind=CK, len=1), PARAMETER :: UIX_DIR_SEP = CHAR(47) @@ -44,7 +44,7 @@ MODULE String_Class INTERFACE strjoin MODULE PROCEDURE strjoin_strings, strjoin_characters, & - & strjoin_strings_array, strjoin_characters_array + strjoin_strings_array, strjoin_characters_array END INTERFACE strjoin PUBLIC :: strjoin @@ -89,7 +89,7 @@ MODULE String_Class INTERFACE index MODULE PROCEDURE sindex_string_string, sindex_string_character, & - & sindex_character_string + sindex_character_string END INTERFACE index !---------------------------------------------------------------------------- @@ -150,7 +150,7 @@ MODULE String_Class INTERFACE verify MODULE PROCEDURE sverify_string_string, sverify_string_character, & - & sverify_character_string + sverify_character_string END INTERFACE verify PUBLIC :: verify From f797ddbf04ddae14941015be521adb94c76c1028 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Thu, 5 Feb 2026 13:08:10 +0900 Subject: [PATCH 2/6] System_Method updating the structure updating the code structure of system_method. Fixing the documentation. --- src/modules/System/CMakeLists.txt | 29 +- src/modules/System/src/SystemInterface.F90 | 765 ++++++++ src/modules/System/src/System_Method.F90 | 1713 +++++------------ src/submodules/System/CMakeLists.txt | 26 + .../src/System_Method@EnquiryMethods.F90 | 0 .../System/src/System_Method@GetMethods.F90 | 28 + .../System/src/System_Method@SetMethods.F90 | 0 7 files changed, 1349 insertions(+), 1212 deletions(-) create mode 100644 src/modules/System/src/SystemInterface.F90 create mode 100644 src/submodules/System/CMakeLists.txt create mode 100644 src/submodules/System/src/System_Method@EnquiryMethods.F90 create mode 100644 src/submodules/System/src/System_Method@GetMethods.F90 create mode 100644 src/submodules/System/src/System_Method@SetMethods.F90 diff --git a/src/modules/System/CMakeLists.txt b/src/modules/System/CMakeLists.txt index 801f528f7..61920f420 100644 --- a/src/modules/System/CMakeLists.txt +++ b/src/modules/System/CMakeLists.txt @@ -16,8 +16,10 @@ # set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -target_sources(${PROJECT_NAME} PRIVATE ${src_path}/System_Method.F90) - +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/SystemInterface.F90 ${src_path}/System_Method.F90 +) set(subproject_name "easifemSystem") @@ -28,16 +30,17 @@ target_link_libraries(${PROJECT_NAME} PUBLIC ${subproject_name}) # target properties set_target_properties( - ${subproject_name} - PROPERTIES POSITION_INDEPENDENT_CODE 1 - SOVERSION ${VERSION_MAJOR} - # OUTPUT_NAME ${PROJECT_NAME} - LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} - RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} - MACOSX_RPATH ON - WINDOWS_EXPORT_ALL_SYMBOLS ON - LINKER_LANGUAGE C) - + ${subproject_name} + PROPERTIES + POSITION_INDEPENDENT_CODE 1 + SOVERSION ${VERSION_MAJOR} + # OUTPUT_NAME ${PROJECT_NAME} + LIBRARY_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_LIBRARY_OUTPUT_DIRECTORY} + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_RUNTIME_OUTPUT_DIRECTORY} + MACOSX_RPATH ON + WINDOWS_EXPORT_ALL_SYMBOLS ON + LINKER_LANGUAGE C +) list(APPEND C_PROJECTS ${subproject_name}) diff --git a/src/modules/System/src/SystemInterface.F90 b/src/modules/System/src/SystemInterface.F90 new file mode 100644 index 000000000..2273318a5 --- /dev/null +++ b/src/modules/System/src/SystemInterface.F90 @@ -0,0 +1,765 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE SystemInterface +USE ISO_C_BINDING, ONLY: C_INT, C_SIZE_T, C_INTPTR_T, C_LONG +USE ISO_C_BINDING, ONLY: C_PTR +IMPLICIT NONE + +PRIVATE +PUBLIC :: System_Alarm +PUBLIC :: System_Calloc +PUBLIC :: System_Clock +PUBLIC :: System_Memcpy +PUBLIC :: System_Free +PUBLIC :: System_Malloc +PUBLIC :: System_Realloc +PUBLIC :: System_Time +PUBLIC :: System_Srand +PUBLIC :: System_Kill +PUBLIC :: System_Errno +PUBLIC :: System_Geteuid +PUBLIC :: System_Getuid +PUBLIC :: System_Getegid +PUBLIC :: System_Getgid +PUBLIC :: System_Setsid +PUBLIC :: System_Getsid +PUBLIC :: System_Getpid +PUBLIC :: System_Getppid +PUBLIC :: System_Umask +PUBLIC :: System_Rand +PUBLIC :: C_Flush +PUBLIC :: System_Initenv + +!---------------------------------------------------------------------------- +! System_Alarm +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION System_Alarm(seconds) BIND(c, name="alarm") + IMPORT :: C_INT + INTEGER(kind=C_INT), VALUE :: seconds + INTEGER(kind=C_INT) :: System_Alarm + END FUNCTION System_Alarm +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Calloc +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION System_Calloc(nelem, elsize) BIND(c, name="calloc") + IMPORT :: C_SIZE_T, C_INTPTR_T + INTEGER(C_SIZE_T), VALUE :: nelem, elsize + INTEGER(C_INTPTR_T) :: System_Calloc + END FUNCTION System_Calloc +END INTERFACE + +!---------------------------------------------------------------------------- +! SYSTEM_CLOCK +!---------------------------------------------------------------------------- + +INTERFACE + PURE FUNCTION SYSTEM_CLOCK() BIND(c, name="clock") + IMPORT :: C_LONG + INTEGER(C_LONG) :: system_clock + END FUNCTION SYSTEM_CLOCK +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Memcpy +!---------------------------------------------------------------------------- + +! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. +! extern void *memcpy (void *dest, const void *src, size_t n); +INTERFACE + SUBROUTINE System_Memcpy(dest, src, n) BIND(C, name='memcpy') + IMPORT :: C_INTPTR_T, C_SIZE_T + INTEGER(C_INTPTR_T), VALUE :: dest + INTEGER(C_INTPTR_T), VALUE :: src + INTEGER(C_SIZE_T), VALUE :: n + END SUBROUTINE System_Memcpy +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Free +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE System_Free(ptr) BIND(c, name="free") + IMPORT :: C_INTPTR_T + INTEGER(C_INTPTR_T), VALUE :: ptr + END SUBROUTINE System_Free +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Malloc +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION System_Malloc(size) BIND(c, name="malloc") + IMPORT :: C_SIZE_T, C_INTPTR_T + INTEGER(C_SIZE_T), VALUE :: size + INTEGER(C_INTPTR_T) :: System_Malloc + END FUNCTION System_Malloc +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Realloc +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION System_Realloc(ptr, size) BIND(c, name="realloc") + IMPORT :: C_SIZE_T, C_INTPTR_T + INTEGER(C_INTPTR_T), VALUE :: ptr + INTEGER(C_SIZE_T), VALUE :: size + INTEGER(C_INTPTR_T) :: System_Realloc + END FUNCTION System_Realloc +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Time +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION System_Time(tloc) BIND(c, name="time") + ! tloc argument should be loaded via C_LOC from iso_c_binding + IMPORT :: C_PTR, C_LONG + TYPE(C_PTR), VALUE :: tloc + INTEGER(C_LONG) :: System_Time + END FUNCTION System_Time +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Srand +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Set seed for pseudo-random number generator system_rand(3f) +! +!# System_Srand +! +! System_Srand(3f) calls the C routine srand(3c) The +! srand(3c)/System_Srand(3f) function uses its argument as the seed +! for a new sequence of pseudo-random integers to be returned by +! system_rand(3f)/rand(3c). These sequences are repeatable by calling +! System_Srand(3f) with the same seed value. If no seed value is +! provided, the system_rand(3f) function is automatically seeded with +! a value of 1. +! +! +!## Usage +! +!```fortran +! program System_Srand +! use M_system, only : System_Srand, system_rand +! implicit none +! integer :: i,j +! do j=1,2 +! call System_Srand(1001) +! do i=1,10 +! write(*,*)system_rand() +! enddo +! write(*,*) +! enddo +! end program System_Srand +!``` + +INTERFACE + SUBROUTINE System_Srand(seed) BIND(c, name='srand') + IMPORT C_INT + INTEGER(kind=C_INT), INTENT(in) :: seed + END SUBROUTINE System_Srand +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Kill +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-04 +! summary: sends a signal to a process or a group of processes +! +!# System_Kill +! +! The kill() function shall send a signal to a process or a group of +! processes specified by pid. The signal to be sent is specified by sig +! and is either one from the list given in or 0. If sig is 0 +! (the null signal), error checking is performed but no signal is actually +! sent. The null signal can be used to check the validity of pid. +! +! For a process to have permission to send a signal to a process designated +! by pid, unless the sending process has appropriate privileges, the real +! or effective user ID of the sending process shall match the real or +! saved set-user-ID of the receiving process. +! +! If pid is greater than 0, sig shall be sent to the process whose process +! ID is equal to pid. +! +! If pid is 0, sig shall be sent to all processes (excluding an unspecified +! set of system processes) whose process group ID is equal to the process +! group ID of the sender, and for which the process has permission to send +! a signal. +! +! If pid is -1, sig shall be sent to all processes (excluding an unspecified +! set of system processes) for which the process has permission to send +! that signal. +! +! If pid is negative, but not -1, sig shall be sent to all processes +! (excluding an unspecified set of system processes) whose process group +! ID is equal to the absolute value of pid, and for which the process has +! permission to send a signal. +! +! If the value of pid causes sig to be generated for the sending process, +! and if sig is not blocked for the calling thread and if no other thread +! has sig unblocked or is waiting in a sigwait() function for sig, either +! sig or at least one pending unblocked signal shall be delivered to the +! sending thread before kill() returns. +! +! The user ID tests described above shall not be applied when sending +! SIGCONT to a process that is a member of the same session as the sending +! process. +! +! An implementation that provides extended security controls may impose +! further implementation-defined restrictions on the sending of signals, +! including the null signal. In particular, the system may deny the +! existence of some or all of the processes specified by pid. +! +! The kill() function is successful if the process has permission to send +! sig to any of the processes specified by pid. If kill() fails, no signal +! shall be sent. +! +! +! Upon successful completion, 0 shall be returned. Otherwise, -1 shall be +! returned and errno set to indicate the error. +! +!## ERRORS +! +! The kill() function shall fail if: +! +! EINVAL The value of the sig argument is an invalid or unsupported signal +! number. +! +! EPERM The process does not have permission to send the signal to +! any receiving process. +! +! ESRCH No process or process group can be found corresponding to +! that specified by pid. The following sections are informative. +! +!## Examples +! +!```fortran +! program demo_system_kill +! use M_system, only : system_kill +! use M_system, only : system_perror +! implicit none +! integer :: i,pid,ios,ierr,signal=9 +! character(len=80) :: argument +! +! do i=1,command_argument_count() +! ! get arguments from command line +! call get_command_argument(i, argument) +! ! convert arguments to integers assuming they are PID numbers +! read(argument,'(i80)',iostat=ios) pid +! if(ios.ne.0)then +! write(*,*)'bad PID=',trim(argument) +! else +! write(*,*)'kill SIGNAL=',signal,' PID=',pid +! ! send signal SIGNAL to pid PID +! ierr=system_kill(pid,signal) +! ! write message if an error was detected +! if(ierr.ne.0)then +! call system_perror('*demo_system_kill*') +! endif +! endif +! enddo +! end program demo_system_kill +!``` + +INTERFACE + FUNCTION System_Kill(c_pid, c_signal) BIND(c, name="kill") RESULT(c_ierr) + IMPORT C_INT + INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_pid + INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_signal + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION System_Kill +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Errno +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-04 +! summary: C error return value +! +!# System_Errno +! +! Many C routines return an error code which can be queried by errno. +! The M_system(3fm) is primarily composed of Fortran routines that call +! C routines. In the cases where an error code is returned vi +! system_errno(3f) these routines will indicate it. +! +!## Examples +! +! Sample program: +! +!```fortran +! program demo_system_errno +! use M_system, only : system_errno, system_unlink, system_perror +! implicit none +! integer :: stat +! stat=system_unlink('not there/OR/anywhere') +! if(stat.ne.0)then +! write(*,*)'err=',system_errno() +! call system_perror('*demo_system_errno*') +! endif +! end program demo_system_errno +!``` +! +!```txt +! Typical Results: +! err= 2 +! *demo_system_errno*: No such file or directory +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Errno() BIND(C, name="my_errno") + IMPORT C_INT + END FUNCTION System_Errno +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Geteuid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get effective UID of current process from Fortran +! +!# System_Geteuid +! +! The system_geteuid(3f) function shall return the effective user +! ID of the calling process. The geteuid() function shall always be +! successful and no return value is reserved to indicate the error. +! +!## Examples +! +!```fortran +! program demo_system_geteuid +! use M_system, only : system_geteuid +! implicit none +! write(*,*)'EFFECTIVE UID=',system_geteuid() +! end program demo_system_geteuid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Geteuid() BIND(C, name="geteuid") + IMPORT C_INT + END FUNCTION System_Geteuid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getuid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: get real UID of current process from Fortran +! +!# System_Getuid +! +! The system_getuid(3f) function shall return the real user ID +! of the calling process. The getuid() function shall always be +! successful and no return value is reserved to indicate the error. +! +!## Examples +! +!```fortran +! program demo_system_getuid +! use M_system, only : system_getuid +! implicit none +! write(*,*)'UID=',system_getuid() +! end program demo_system_getuid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Getuid() BIND(C, name="getuid") + IMPORT C_INT + END FUNCTION System_Getuid +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: get the effective group ID (GID) of current process from Fortran +! +!# System_Getegid +! +! The getegid() function returns the effective group ID of the +! calling process. +! +! The getegid() should always be successful and no return value is +! reserved to indicate an error. +! +!## Examples +! +!```fortran +! program demo_system_getegid +! use M_system, only : system_getegid +! implicit none +! write(*,*)'GID=',system_getegid() +! end program demo_system_getegid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Getegid() BIND(C, name="getegid") + IMPORT C_INT + END FUNCTION System_Getegid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getgid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: get the real group ID (GID) of current process from Fortran +! +!# System_Getgid +! +! The getgid() function returns the real group ID of the calling process. +! +! The getgid() should always be successful and no return value is +! reserved to indicate an error. +! +!## Examples +! +!```fortran +! program demo_system_getgid +! use M_system, only : system_getgid +! implicit none +! write(*,*)'GID=',system_getgid() +! end program demo_system_getgid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Getgid() BIND(C, name="getgid") + IMPORT C_INT + END FUNCTION System_Getgid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Setsid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: create session and set the process group ID of a session leader +! +!# System_Setsid +! +! The setsid() function creates a new session, if the calling process +! is not a process group leader. Upon return the +! calling process shall be the session leader of this new session, +! shall be the process group leader of a new process +! group, and shall have no controlling terminal. +! The process group ID of the calling process shall be set equal to the +! process ID of the calling process. +! The calling process shall be the only process in the new process group +! and the only process in the new session. +! +! Upon successful completion, setsid() shall return the value of +! the new process group ID of the calling process. Otherwise, +! it shall return �-1 and set errno to indicate the error. +! +!## Errors +! +! The setsid() function shall fail if: +! +!- The calling process is already a process group leader +!- the process group ID of a process other than the calling +! process matches the process ID of the calling process. +! +!## Examples +! +!```fortran +! program demo_system_setsid +! use M_system, only : system_setsid +! implicit none +! write(*,*)'SID=',system_setsid() +! end program demo_system_setsid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Setsid() BIND(C, name="setsid") + IMPORT C_INT + END FUNCTION System_Setsid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getsid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get the process group ID of a session leader +! +!# System_Getsid +! +! The system_getsid() function obtains the process group ID of the +! process that is the session leader of the process specified by pid. +! If pid is 0, it specifies the calling process. +! +! Upon successful completion, system_getsid() shall return the process group +! ID of the session leader of the specified process. Otherwise, +! it shall return -1 and set errno to indicate the error. +! +! +!## Usage +! +!```fortran +! program demo_system_getsid +! use M_system, only : system_getsid +! use ISO_C_BINDING, only : c_int +! implicit none +! write(*,*)'SID=',system_getsid(0_c_int) +! end program demo_system_getsid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Getsid(c_pid) BIND(C, name="getsid") + IMPORT C_INT + INTEGER(kind=C_INT) :: c_pid + END FUNCTION System_Getsid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getpid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get PID (process ID) of current process from Fortran +! +!# System_Getpid +! +! The system_getpid() function returns the process ID of the +! calling process. +! +! The value returned is the integer process ID. The system_getpid() +! function shall always be successful and no return value is reserved +! to indicate an error. +! +! +!## Usage +! +!```fortran +! program demo_system_getpid +! use M_system, only : system_getpid +! implicit none +! write(*,*)'PID=',system_getpid() +! end program demo_system_getpid +!``` + +INTERFACE + PURE INTEGER(kind=C_INT) FUNCTION System_Getpid() BIND(C, name="getpid") + IMPORT C_INT + END FUNCTION System_Getpid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getppid +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: get parent process ID (PPID) of current process from Fortran +! +!# System_Getppid +! +! The system_getppid() function returns the parent process ID of +! the calling process. +! +! The system_getppid() function should always be successful and no +! return value is reserved to indicate an error. +! +!## Examples +! +!```fortran +! program demo_system_getppid +! use M_system, only : system_getppid +! implicit none +! write(*,*)'PPID=',system_getppid() +! end program demo_system_getppid +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Getppid() BIND(C, name="getppid") + IMPORT C_INT + END FUNCTION System_Getppid +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Set and get the file mode creation mask +! +!# System_Umask +! +! The system_umask() function shall set the file mode creation mask of the +! process to cmask and return the previous value of the mask. Only +! the file permission bits of cmask (see ) are used; +! the meaning of the other bits is implementation-defined. +! +! The file mode creation mask of the process is used to turn off +! permission bits in the mode argument supplied during calls to +! the following functions: +! +! Bit positions that are set in cmask are cleared in the mode of +! the created file. +! +! The file permission bits in the value returned by umask() shall be +! the previous value of the file mode creation mask. The state of any +! other bits in that value is unspecified, except that a subsequent +! call to umask() with the returned value as cmask shall leave the +! state of the mask the same as its state before the first call, +! including any unspecified use of those bits. +! +! +!## Examples +! +!```fortran +! program demo_system_umask +! use M_system, only : system_getumask, system_setumask +! implicit none +! integer value +! integer mask +! mask=O'002' +! value=system_setumask(mask) +! write(*,'(a,"octal=",O4.4," decimal=",i0)')'OLD VALUE=',value,value +! value=system_getumask() +! write(*,'(a,"octal=",O4.4," decimal=",i0)')'MASK=',mask,mask +! write(*,'(a,"octal=",O4.4," decimal=",i0)')'NEW VALUE=',value,value +! end program demo_system_umask +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Umask(umask_value) BIND(C, name="umask") + IMPORT C_INT + INTEGER(kind=C_INT), VALUE :: umask_value + END FUNCTION System_Umask +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Rand +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Call pseudo-random number generator rand(3c) +! +!# System_Rand +! +! Use rand(3c) to generate pseudo-random numbers. +! +!## Examples +! +!## Usage +! +!```fortran +! program demo_system_rand +! use M_system, only : system_srand, system_rand +! implicit none +! integer :: i +! +! call system_srand(1001) +! do i=1,10 +! write(*,*)system_rand() +! enddo +! write(*,*) +! end program demo_system_rand +!``` + +INTERFACE + INTEGER(kind=C_INT) FUNCTION System_Rand() BIND(C, name="rand") + IMPORT C_INT + END FUNCTION System_Rand +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Flush +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_Flush() BIND(C, name="my_flush") + END SUBROUTINE C_Flush +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Initenv +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Initialize environment table pointer and size +! so table can be read by readenv(3f) +! +!# System_Initenv +! +! A simple interface allows reading the environment variable table +! of the process. Call system_initenv(3f) to initialize reading the +! environment table, then call system_readenv(3f) until a blank line +! is returned. If more than one thread reads the environment or the +! environment is changed while being read the results are undefined. +! +! +!## Examples +! +!```fortran +! program demo_system_initenv +! use M_system, only : system_initenv, system_readenv +! character(len=:),allocatable :: string +! call system_initenv() +! do +! string=system_readenv() +! if(string.eq.'')then +! exit +! else +! write(*,'(a)')string +! endif +! enddo +! end program demo_system_initenv +!``` + +INTERFACE + SUBROUTINE System_Initenv() BIND(C, NAME='my_initenv') + END SUBROUTINE System_Initenv +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemInterface diff --git a/src/modules/System/src/System_Method.F90 b/src/modules/System/src/System_Method.F90 index a39ca633f..57cb13834 100755 --- a/src/modules/System/src/System_Method.F90 +++ b/src/modules/System/src/System_Method.F90 @@ -1,31 +1,23 @@ -! This program is a part of EASIFEM library. -! This program is directly taken from the -! source: https://github.com/urbanjost/M_system. +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. ! The original name of the program has been changed ! from M_SYSTEM to System_Method. ! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-04 +! summary: Fortran interface to C system interface ! -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +!# System_Method ! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. +! Fortran interface to C system interface. ! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!> -!##NAME -! M_system(3fm) - [M_system::INTRO] Fortran interface to C system interface -! (LICENSE:PD) -!##SYNOPSIS +!## Public objects ! ! Public objects: ! @@ -63,6 +55,7 @@ ! use M_system, only : system_cpu_time ! !##DESCRIPTION +! ! M_system(3fm) is a collection of Fortran procedures that call C ! or a C wrapper using the ISO_C_BINDING interface to access system calls. ! System calls are a special set of functions used by programs to communicate @@ -76,7 +69,9 @@ ! ! One rule-of-thumb that should always be followed when calling a system ! call -- Always check the return value. -!##ENVIRONMENT ACCESS +! +!## ENVIRONMENT ACCESS +! ! o system_putenv(3f): call putenv(3c) ! o system_getenv(3f): function call to get_environment_variable(3f) ! o system_unsetenv(3f): call unsetenv(3c) to remove variable from environment @@ -85,7 +80,9 @@ ! o system_initenv(3f): initialize environment table for reading ! o system_readenv(3f): read next entry from environment table ! o system_clearenv(3f): emulate clearenv(3c) to clear environment -!##FILE SYSTEM +! +!## FILE SYSTEM +! ! o system_chdir(3f): call chdir(3c) to change current directory of a process ! o system_getcwd(3f): call getcwd(3c) to get pathname of current working directory ! @@ -120,16 +117,23 @@ ! ! o fileglob(3f): Returns list of files using a file globbing pattern ! -!##STREAM IO +!## STREAM IO +! ! o system_getc(3f): get a character from stdin ! o system_putc(3f): put a character on stdout -!##RANDOM NUMBERS +! +!## RANDOM NUMBERS +! ! o system_srand(3f): call srand(3c) ! o system_rand(3f): call rand(3c) -!##C ERROR INFORMATION +! +!## C ERROR INFORMATION +! ! o system_errno(3f): return errno(3c) ! o system_perror(3f): call perror(3c) to display last C error message -!##QUERIES +! +!## QUERIES +! ! o system_geteuid(3f): call geteuid(3c) ! o system_getuid(3f): call getuid(3c) ! o system_getegid(3f): call getegid(3c) @@ -143,7 +147,8 @@ ! o system_getgrgid(3f): get group name associated with given GID ! o system_cpu_time(3f) : get processor time in seconds using times(3c) ! -!##FUTURE DIRECTIONS +!## FUTURE DIRECTIONS +! ! A good idea of what system routines are commonly required is to refer ! to the POSIX binding standards. (Note: IEEE 1003.9-1992 was withdrawn 6 ! February 2003.) The IEEE standard covering Fortran 77 POSIX bindings @@ -152,7 +157,8 @@ ! many university networks). For those who do have such access, the link ! is: POSIX Fortran 77 Language Interfaces (IEEE Std 1003.9-1992) (pdf) ! -!##SEE ALSO +!## SEE ALSO +! ! Some vendors provide their own way to access POSIX functions and make ! those available as modules; for instance ... ! @@ -166,14 +172,16 @@ ! o fortranposix. MODULE System_Method -USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR -use,intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer, c_null_char, c_null_ptr +USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR +USE ISO_C_BINDING, ONLY: C_PTR, c_f_pointer, C_NULL_CHAR, C_NULL_PTR USE, INTRINSIC :: ISO_C_BINDING USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT8, INT16, INT32, INT64 !!, real32, real64, real128, dp=>real128 - +USE SystemInterface IMPLICIT NONE + PRIVATE + ! C types. Might be platform dependent INTEGER, PARAMETER, PUBLIC :: mode_t = INT32 @@ -183,14 +191,20 @@ MODULE System_Method !-!public :: system_getc !-!public :: system_putc -PUBLIC :: system_getpid ! return process ID -PUBLIC :: system_getppid ! return parent process ID -PUBLIC :: system_getuid, system_geteuid ! return user ID -PUBLIC :: system_getgid, system_getegid ! return group ID +PUBLIC :: system_getpid +!! return process ID +PUBLIC :: system_getppid +!! return parent process ID +PUBLIC :: system_getuid, system_geteuid +!! return user ID +PUBLIC :: system_getgid, system_getegid +!! return group ID PUBLIC :: system_setsid PUBLIC :: system_getsid -PUBLIC :: system_kill ! (pid, signal) kill process (defaults: pid=0, signal=SIGTERM) -PUBLIC :: system_signal ! (signal,[handler]) install signal handler subroutine +PUBLIC :: system_kill +!! (pid, signal) kill process (defaults: pid=0, signal=SIGTERM) +PUBLIC :: system_signal +!! (signal,[handler]) install signal handler subroutine PUBLIC :: system_errno PUBLIC :: system_perror @@ -204,915 +218,119 @@ MODULE System_Method PUBLIC :: system_readenv PUBLIC :: system_clearenv -PUBLIC :: system_stat ! call stat(3c) to determine system information of file by name -PUBLIC :: system_perm ! create string representing file permission and type -PUBLIC :: system_access ! determine filename access or existence -PUBLIC :: system_isdir ! determine if filename is a directory -PUBLIC :: system_islnk ! determine if filename is a link -PUBLIC :: system_isreg ! determine if filename is a regular file -PUBLIC :: system_isblk ! determine if filename is a block device -PUBLIC :: system_ischr ! determine if filename is a character device -PUBLIC :: system_isfifo ! determine if filename is a fifo - named pipe -PUBLIC :: system_issock ! determine if filename is a socket -PUBLIC :: system_realpath ! resolve pathname +PUBLIC :: system_stat +!! call stat(3c) to determine system information of file by name +PUBLIC :: system_perm +!! create string representing file permission and type +PUBLIC :: system_access +!! determine filename access or existence +PUBLIC :: system_isdir +!! determine if filename is a directory +PUBLIC :: system_islnk +!! determine if filename is a link +PUBLIC :: system_isreg +!! determine if filename is a regular file +PUBLIC :: system_isblk +!! determine if filename is a block device +PUBLIC :: system_ischr +!! determine if filename is a character device +PUBLIC :: system_isfifo +!! determine if filename is a fifo - named pipe +PUBLIC :: system_issock +!! determine if filename is a socket +PUBLIC :: system_realpath +!! resolve pathname PUBLIC :: system_chdir PUBLIC :: system_rmdir PUBLIC :: system_remove PUBLIC :: system_rename - -PUBLIC :: system_mkdir -PUBLIC :: system_mkfifo -PUBLIC :: system_chmod -PUBLIC :: system_chown -PUBLIC :: system_link -PUBLIC :: system_unlink -PUBLIC :: system_utime - -PUBLIC :: system_setumask -PUBLIC :: system_getumask -PUBLIC :: system_umask - -PUBLIC :: system_getcwd - -PUBLIC :: system_opendir -PUBLIC :: system_readdir -PUBLIC :: system_rewinddir -PUBLIC :: system_closedir - -PUBLIC :: system_cpu_time - -PUBLIC :: system_uname -PUBLIC :: system_gethostname -PUBLIC :: system_getlogin -PUBLIC :: system_getpwuid -PUBLIC :: system_getgrgid -PUBLIC :: fileglob - -PUBLIC :: system_alarm -PUBLIC :: system_calloc -PUBLIC :: system_clock -PUBLIC :: system_time -!public :: system_time -!public :: system_qsort - -PUBLIC :: system_realloc -PUBLIC :: system_malloc -PUBLIC :: system_free -PUBLIC :: system_memcpy - -PUBLIC :: system_dir - -public :: R_GRP,R_OTH,R_USR,RWX_G,RWX_O,RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR,DEFFILEMODE,ACCESSPERMS -PUBLIC :: R_OK, W_OK, X_OK, F_OK ! for system_access - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: dirent_SYSTEMA - INTEGER(C_LONG) :: d_ino - INTEGER(C_LONG) :: d_off; ! __off_t, check size - INTEGER(C_SHORT) :: d_reclen - CHARACTER(len=1, kind=C_CHAR) :: d_name(256) -END TYPE - -TYPE, BIND(C) :: dirent_CYGWIN - INTEGER(C_INT) :: d_version - INTEGER(C_LONG) :: d_ino - CHARACTER(kind=C_CHAR) :: d_type - CHARACTER(kind=C_CHAR) :: d_unused1(3) - INTEGER(C_INT) :: d_internal1 - CHARACTER(len=1, kind=C_CHAR) :: d_name(256) -END TYPE - -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_alarm(seconds) BIND(c, name="alarm") - IMPORT C_INT - INTEGER(kind=C_INT), VALUE :: seconds - INTEGER(kind=C_INT) system_alarm - END FUNCTION system_alarm -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_calloc(nelem, elsize) BIND(c, name="calloc") - IMPORT C_SIZE_T, C_INTPTR_T - INTEGER(C_SIZE_T), VALUE :: nelem, elsize - INTEGER(C_INTPTR_T) system_calloc - END FUNCTION system_calloc -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - PURE FUNCTION SYSTEM_CLOCK() BIND(c, name="clock") - IMPORT C_LONG - INTEGER(C_LONG) system_clock - END FUNCTION system_clock -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! Copy N bytes of SRC to DEST, no aliasing or overlapping allowed. -! extern void *memcpy (void *dest, const void *src, size_t n); -INTERFACE - SUBROUTINE system_memcpy(dest, src, n) BIND(C, name='memcpy') - IMPORT C_INTPTR_T, C_SIZE_T - INTEGER(C_INTPTR_T), VALUE :: dest - INTEGER(C_INTPTR_T), VALUE :: src - INTEGER(C_SIZE_T), VALUE :: n - END SUBROUTINE system_memcpy -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - SUBROUTINE system_free(ptr) BIND(c, name="free") - IMPORT C_INTPTR_T - INTEGER(C_INTPTR_T), VALUE :: ptr - END SUBROUTINE system_free -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_malloc(size) BIND(c, name="malloc") - IMPORT C_SIZE_T, C_INTPTR_T - INTEGER(C_SIZE_T), VALUE :: size - INTEGER(C_INTPTR_T) system_malloc - END FUNCTION system_malloc -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_realloc(ptr, size) BIND(c, name="realloc") - IMPORT C_SIZE_T, C_INTPTR_T - INTEGER(C_INTPTR_T), VALUE :: ptr - INTEGER(C_SIZE_T), VALUE :: size - INTEGER(C_INTPTR_T) system_realloc - END FUNCTION system_realloc -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - FUNCTION system_time(tloc) BIND(c, name="time") - ! tloc argument should be loaded via C_LOC from iso_c_binding - IMPORT C_PTR, C_LONG - TYPE(C_PTR), VALUE :: tloc - INTEGER(C_LONG) system_time - END FUNCTION system_time -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! abstract interface -! integer(4) function compar_iface(a, b) -! import c_int -! integer, intent(in) :: a, b -!-! Until implement TYPE(*) -! integer(kind=c_int) :: compar_iface -! end function compar_iface -! end interface -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -! interface -! subroutine system_qsort(base, nel, width, compar) bind(c, name="qsort") -! import C_SIZE_T, compar_iface -! integer :: base -!-! Until implement TYPE(*) -! integer(C_SIZE_T), value :: nel, width -! procedure(compar_iface) compar -! end subroutine system_qsort -! end interface -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_srand(3f) - [M_system:PSEUDORANDOM] set seed for pseudo-random number generator system_rand(3f) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_srand() -!! -!!##DESCRIPTION -!! system_srand(3f) calls the C routine srand(3c) The -!! srand(3c)/system_srand(3f) function uses its argument as the seed -!! for a new sequence of pseudo-random integers to be returned by -!! system_rand(3f)/rand(3c). These sequences are repeatable by calling -!! system_srand(3f) with the same seed value. If no seed value is -!! provided, the system_rand(3f) function is automatically seeded with -!! a value of 1. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_srand -!! use M_system, only : system_srand, system_rand -!! implicit none -!! integer :: i,j -!! do j=1,2 -!! call system_srand(1001) -!! do i=1,10 -!! write(*,*)system_rand() -!! enddo -!! write(*,*) -!! enddo -!! end program demo_system_srand -!! expected results: -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -!! -!!##SEE ALSO -!! drand48(3c), random(3c) -! void srand_system(int *seed) -INTERFACE - SUBROUTINE system_srand(seed) BIND(c, name='srand') - IMPORT C_INT - INTEGER(kind=C_INT), INTENT(in) :: seed - END SUBROUTINE system_srand -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_kill(3f) - [M_system:SIGNALS] send a signal to a process or a group of processes -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_kill(pid,sig) -!! -!! integer,intent(in) :: pid -!! integer,intent(in) :: sig -!! -!!##DESCRIPTION -!! -!! The kill() function shall send a signal to a process or a group of -!! processes specified by pid. The signal to be sent is specified by sig -!! and is either one from the list given in or 0. If sig is 0 -!! (the null signal), error checking is performed but no signal is actually -!! sent. The null signal can be used to check the validity of pid. -!! -!! For a process to have permission to send a signal to a process designated -!! by pid, unless the sending process has appropriate privileges, the real -!! or effective user ID of the sending process shall match the real or -!! saved set-user-ID of the receiving process. -!! -!! If pid is greater than 0, sig shall be sent to the process whose process -!! ID is equal to pid. -!! -!! If pid is 0, sig shall be sent to all processes (excluding an unspecified -!! set of system processes) whose process group ID is equal to the process -!! group ID of the sender, and for which the process has permission to send -!! a signal. -!! -!! If pid is -1, sig shall be sent to all processes (excluding an unspecified -!! set of system processes) for which the process has permission to send -!! that signal. -!! -!! If pid is negative, but not -1, sig shall be sent to all processes -!! (excluding an unspecified set of system processes) whose process group -!! ID is equal to the absolute value of pid, and for which the process has -!! permission to send a signal. -!! -!! If the value of pid causes sig to be generated for the sending process, -!! and if sig is not blocked for the calling thread and if no other thread -!! has sig unblocked or is waiting in a sigwait() function for sig, either -!! sig or at least one pending unblocked signal shall be delivered to the -!! sending thread before kill() returns. -!! -!! The user ID tests described above shall not be applied when sending -!! SIGCONT to a process that is a member of the same session as the sending -!! process. -!! -!! An implementation that provides extended security controls may impose -!! further implementation-defined restrictions on the sending of signals, -!! including the null signal. In particular, the system may deny the -!! existence of some or all of the processes specified by pid. -!! -!! The kill() function is successful if the process has permission to send -!! sig to any of the processes specified by pid. If kill() fails, no signal -!! shall be sent. -!! -!! -!!##RETURN VALUE -!! -!! Upon successful completion, 0 shall be returned. Otherwise, -1 shall be -!! returned and errno set to indicate the error. -!! -!!##ERRORS -!! The kill() function shall fail if: -!! -!! EINVAL The value of the sig argument is an invalid or unsupported -!! signal number. -!! EPERM The process does not have permission to send the signal to -!! any receiving process. -!! ESRCH No process or process group can be found corresponding to -!! that specified by pid. The following sections are informative. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_kill -!! use M_system, only : system_kill -!! use M_system, only : system_perror -!! implicit none -!! integer :: i,pid,ios,ierr,signal=9 -!! character(len=80) :: argument -!! -!! do i=1,command_argument_count() -!! ! get arguments from command line -!! call get_command_argument(i, argument) -!! ! convert arguments to integers assuming they are PID numbers -!! read(argument,'(i80)',iostat=ios) pid -!! if(ios.ne.0)then -!! write(*,*)'bad PID=',trim(argument) -!! else -!! write(*,*)'kill SIGNAL=',signal,' PID=',pid -!! ! send signal SIGNAL to pid PID -!! ierr=system_kill(pid,signal) -!! ! write message if an error was detected -!! if(ierr.ne.0)then -!! call system_perror('*demo_system_kill*') -!! endif -!! endif -!! enddo -!! end program demo_system_kill -!! -!!##SEE ALSO -!! getpid(), raise(), setsid(), sigaction(), sigqueue(), - -! int kill(pid_t pid, int sig); -INTERFACE - FUNCTION system_kill(c_pid, c_signal) BIND(c, name="kill") RESULT(c_ierr) - IMPORT C_INT - INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_pid - INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_signal - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_errno(3f) - [M_system:ERROR_PROCESSING] C error return value -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_errno() -!! -!!##DESCRIPTION -!! Many C routines return an error code which can be queried by errno. -!! The M_system(3fm) is primarily composed of Fortran routines that call -!! C routines. In the cases where an error code is returned vi system_errno(3f) -!! these routines will indicate it. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_errno -!! use M_system, only : system_errno, system_unlink, system_perror -!! implicit none -!! integer :: stat -!! stat=system_unlink('not there/OR/anywhere') -!! if(stat.ne.0)then -!! write(*,*)'err=',system_errno() -!! call system_perror('*demo_system_errno*') -!! endif -!! end program demo_system_errno -!! -!! Typical Results: -!! -!! err= 2 -!! *demo_system_errno*: No such file or directory - -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_errno() BIND(C, name="my_errno") - IMPORT C_INT - END FUNCTION system_errno -END INTERFACE -!-! if a macro on XLF -!-! interface system_errno -!-! function ierrno_() bind(c, name="ierrno_") -!-! import c_int -!-! integer(kind=c_int) :: ierrno_ -!-! end function system_errno -!-! end interface -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_geteuid(3f) - [M_system:QUERY] get effective UID of current process from Fortran by calling geteuid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_geteuid() -!! -!!##DESCRIPTION -!! The system_geteuid(3f) function shall return the effective user -!! ID of the calling process. The geteuid() function shall always be -!! successful and no return value is reserved to indicate the error. -!!##EXAMPLE -!! -!! Get group ID from Fortran: -!! -!! program demo_system_geteuid -!! use M_system, only : system_geteuid -!! implicit none -!! write(*,*)'EFFECTIVE UID=',system_geteuid() -!! end program demo_system_geteuid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_geteuid() BIND(C, name="geteuid") - IMPORT C_INT - END FUNCTION system_geteuid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getuid(3f) - [M_system:QUERY] get real UID of current process from Fortran by calling getuid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getuid() -!! -!!##DESCRIPTION -!! The system_getuid(3f) function shall return the real user ID -!! of the calling process. The getuid() function shall always be -!! successful and no return value is reserved to indicate the error. -!!##EXAMPLE -!! -!! Get group ID from Fortran: -!! -!! program demo_system_getuid -!! use M_system, only : system_getuid -!! implicit none -!! write(*,*)'UID=',system_getuid() -!! end program demo_system_getuid -!! -!! Results: -!! -!! UID= 197609 -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getuid() BIND(C, name="getuid") - IMPORT C_INT - END FUNCTION system_getuid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getegid(3f) - [M_system:QUERY] get the effective group ID (GID) of current process from Fortran by calling getegid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getegid() -!!##DESCRIPTION -!! The getegid() function returns the effective group ID of the -!! calling process. -!! -!!##RETURN VALUE -!! The getegid() should always be successful and no return value is -!! reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(), -!! setregid(), setreuid(), setuid() -!! -!!##EXAMPLE -!! -!! Get group ID from Fortran -!! -!! program demo_system_getegid -!! use M_system, only : system_getegid -!! implicit none -!! write(*,*)'GID=',system_getegid() -!! end program demo_system_getegid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getegid() BIND(C, name="getegid") - IMPORT C_INT - END FUNCTION system_getegid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getgid(3f) - [M_system:QUERY] get the real group ID (GID) of current process from Fortran by calling getgid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getgid() -!!##DESCRIPTION -!! The getgid() function returns the real group ID of the calling process. -!! -!!##RETURN VALUE -!! The getgid() should always be successful and no return value is -!! reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! getegid(), system_geteuid(), getuid(), setegid(), seteuid(), setgid(), -!! setregid(), setreuid(), setuid() -!! -!!##EXAMPLE -!! -!! Get group ID from Fortran -!! -!! program demo_system_getgid -!! use M_system, only : system_getgid -!! implicit none -!! write(*,*)'GID=',system_getgid() -!! end program demo_system_getgid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getgid() BIND(C, name="getgid") - IMPORT C_INT - END FUNCTION system_getgid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_setsid(3f) - [M_system:QUERY] create session and set the process group ID of a session leader -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_setsid(pid) -!! integer(kind=c_int) :: pid -!!##DESCRIPTION -!! The setsid() function creates a new session, if the calling process is not a process group leader. Upon return the -!! calling process shall be the session leader of this new session, shall be the process group leader of a new process -!! group, and shall have no controlling terminal. The process group ID of the calling process shall be set equal to the -!! process ID of the calling process. The calling process shall be the only process in the new process group and the only -!! process in the new session. -!! -!!##RETURN VALUE -!! Upon successful completion, setsid() shall return the value of the new process group ID of the calling process. Otherwise, -!! it shall return �-1 and set errno to indicate the error. -!!##ERRORS -!! The setsid() function shall fail if: -!! -!! o The calling process is already a process group leader -!! o the process group ID of a process other than the calling process matches the process ID of the calling process. -!!##EXAMPLE -!! -!! Set SID from Fortran -!! -!! program demo_system_setsid -!! use M_system, only : system_setsid -!! implicit none -!! write(*,*)'SID=',system_setsid() -!! end program demo_system_setsid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_setsid() BIND(C, name="setsid") - IMPORT C_INT - END FUNCTION system_setsid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getsid(3f) - [M_system:QUERY] get the process group ID of a session leader -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getsid(pid) -!! integer(kind=c_int) :: pid -!!##DESCRIPTION -!! The system_getsid() function obtains the process group ID of the -!! process that is the session leader of the process specified by pid. -!! If pid is 0, it specifies the calling process. -!!##RETURN VALUE -!! Upon successful completion, system_getsid() shall return the process group -!! ID of the session leader of the specified process. Otherwise, -!! it shall return -1 and set errno to indicate the error. -!!##EXAMPLE -!! -!! Get SID from Fortran -!! -!! program demo_system_getsid -!! use M_system, only : system_getsid -!! use ISO_C_BINDING, only : c_int -!! implicit none -!! write(*,*)'SID=',system_getsid(0_c_int) -!! end program demo_system_getsid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getsid(c_pid) BIND(C, name="getsid") - IMPORT C_INT - INTEGER(kind=C_INT) :: c_pid - END FUNCTION system_getsid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getpid(3f) - [M_system:QUERY] get PID (process ID) of current process from Fortran by calling getpid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer function system_getpid() -!!##DESCRIPTION -!! The system_getpid() function returns the process ID of the -!! calling process. -!!##RETURN VALUE -!! The value returned is the integer process ID. The system_getpid() -!! function shall always be successful and no return value is reserved -!! to indicate an error. -!!##EXAMPLE -!! -!! Get process PID from Fortran -!! -!! program demo_system_getpid -!! use M_system, only : system_getpid -!! implicit none -!! write(*,*)'PID=',system_getpid() -!! end program demo_system_getpid - -INTERFACE - PURE INTEGER(kind=C_INT) FUNCTION system_getpid() BIND(C, name="getpid") - IMPORT C_INT - END FUNCTION system_getpid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_getppid(3f) - [M_system:QUERY] get parent process ID (PPID) of current process from Fortran by calling getppid(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_getppid() -!!##DESCRIPTION -!! The system_getppid() function returns the parent process ID of -!! the calling process. -!! -!!##RETURN VALUE -!! The system_getppid() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! exec, fork(), getpgid(), getpgrp(), getpid(), kill(), -!! setpgid(), setsid() -!! -!!##EXAMPLE -!! -!! Get parent process PID (PPID) from Fortran -!! -!! program demo_system_getppid -!! use M_system, only : system_getppid -!! implicit none -!! write(*,*)'PPID=',system_getppid() -!! end program demo_system_getppid -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_getppid() BIND(C, name="getppid") - IMPORT C_INT - END FUNCTION system_getppid -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_umask(3fp) - [M_system] set and get the file mode creation mask -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) function system_umask(umask_value) -!! -!!##DESCRIPTION -!! The system_umask() function shall set the file mode creation mask of the -!! process to cmask and return the previous value of the mask. Only -!! the file permission bits of cmask (see ) are used; -!! the meaning of the other bits is implementation-defined. -!! -!! The file mode creation mask of the process is used to turn off -!! permission bits in the mode argument supplied during calls to -!! the following functions: -!! -!! * open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat() -!! * mknod(), mknodat() -!! * mq_open() -!! * sem_open() -!! -!! Bit positions that are set in cmask are cleared in the mode of the created file. -!! -!!##RETURN VALUE -!! The file permission bits in the value returned by umask() shall be -!! the previous value of the file mode creation mask. The state of any -!! other bits in that value is unspecified, except that a subsequent -!! call to umask() with the returned value as cmask shall leave the -!! state of the mask the same as its state before the first call, -!! including any unspecified use of those bits. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_umask -!! use M_system, only : system_getumask, system_setumask -!! implicit none -!! integer value -!! integer mask -!! mask=O'002' -!! value=system_setumask(mask) -!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'OLD VALUE=',value,value -!! value=system_getumask() -!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'MASK=',mask,mask -!! write(*,'(a,"octal=",O4.4," decimal=",i0)')'NEW VALUE=',value,value -!! end program demo_system_umask -!! -!! Expected results: -!! -!! OLD VALUE=octal=0022 decimal=18 -!! MASK=octal=0002 decimal=2 -!! NEW VALUE=octal=0002 decimal=2 -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_umask(umask_value) BIND(C, name="umask") - IMPORT C_INT - INTEGER(kind=C_INT), VALUE :: umask_value - END FUNCTION system_umask -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_rand(3f) - [M_system:PSEUDORANDOM] call pseudo-random number generator rand(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer(kind=c_int) :: function system_rand() -!!##DESCRIPTION -!! Use rand(3c) to generate pseudo-random numbers. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rand -!! use M_system, only : system_srand, system_rand -!! implicit none -!! integer :: i -!! -!! call system_srand(1001) -!! do i=1,10 -!! write(*,*)system_rand() -!! enddo -!! write(*,*) -!! -!! end program demo_system_rand -!! expected results: -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -!! -!! 1512084687 -!! 1329390995 -!! 1874040748 -!! 60731048 -!! 239808950 -!! 2017891911 -!! 22055588 -!! 1105177318 -!! 347750200 -!! 1729645355 -INTERFACE - INTEGER(kind=C_INT) FUNCTION system_rand() BIND(C, name="rand") - IMPORT C_INT - END FUNCTION system_rand -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +PUBLIC :: system_mkdir +PUBLIC :: system_mkfifo +PUBLIC :: system_chmod +PUBLIC :: system_chown +PUBLIC :: system_link +PUBLIC :: system_unlink +PUBLIC :: system_utime + +PUBLIC :: system_setumask +PUBLIC :: system_getumask +PUBLIC :: system_umask + +PUBLIC :: system_getcwd + +PUBLIC :: system_opendir +PUBLIC :: system_readdir +PUBLIC :: system_rewinddir +PUBLIC :: system_closedir + +PUBLIC :: system_cpu_time + +PUBLIC :: system_uname +PUBLIC :: system_gethostname +PUBLIC :: system_getlogin +PUBLIC :: system_getpwuid +PUBLIC :: system_getgrgid +PUBLIC :: fileglob + +PUBLIC :: system_alarm +PUBLIC :: system_calloc +PUBLIC :: system_clock +PUBLIC :: system_time +!public :: system_time +!public :: system_qsort + +PUBLIC :: system_realloc +PUBLIC :: system_malloc +PUBLIC :: system_free +PUBLIC :: system_memcpy + +PUBLIC :: system_dir + +PUBLIC :: R_GRP, R_OTH, R_USR, RWX_G, RWX_O, RWX_U, W_GRP, W_OTH, W_USR, X_GRP +PUBLIC :: X_OTH, X_USR, DEFFILEMODE, ACCESSPERMS +PUBLIC :: R_OK, W_OK, X_OK, F_OK +!! for system_access + +!---------------------------------------------------------------------------- +! dirent_SYSTEMA +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: dirent_SYSTEMA + INTEGER(C_LONG) :: d_ino + INTEGER(C_LONG) :: d_off + INTEGER(C_SHORT) :: d_reclen + CHARACTER(len=1, kind=C_CHAR) :: d_name(256) +END TYPE dirent_SYSTEMA + +!---------------------------------------------------------------------------- +! dirent_CYGWIN +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: dirent_CYGWIN + INTEGER(C_INT) :: d_version + INTEGER(C_LONG) :: d_ino + CHARACTER(kind=C_CHAR) :: d_type + CHARACTER(kind=C_CHAR) :: d_unused1(3) + INTEGER(C_INT) :: d_internal1 + CHARACTER(len=1, kind=C_CHAR) :: d_name(256) +END TYPE dirent_CYGWIN + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + INTERFACE SUBROUTINE c_flush() BIND(C, name="my_flush") END SUBROUTINE c_flush END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_initenv(3f) - [M_system:ENVIRONMENT] initialize environment table pointer and size so table can be read by readenv(3f) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_initenv() -!!##DESCRIPTION -!! A simple interface allows reading the environment variable table -!! of the process. Call system_initenv(3f) to initialize reading the -!! environment table, then call system_readenv(3f) until a blank line -!! is returned. If more than one thread reads the environment or the -!! environment is changed while being read the results are undefined. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_initenv -!! use M_system, only : system_initenv, system_readenv -!! character(len=:),allocatable :: string -!! call system_initenv() -!! do -!! string=system_readenv() -!! if(string.eq.'')then -!! exit -!! else -!! write(*,'(a)')string -!! endif -!! enddo -!! end program demo_system_initenv -!! -!! Sample results: -!! -!! USERDOMAIN_ROAMINGPROFILE=buzz -!! HOMEPATH=\Users\JSU -!! APPDATA=C:\Users\JSU\AppData\Roaming -!! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man::: -!! DISPLAYNUM=0 -!! ProgramW6432=C:\Program Files -!! HOSTNAME=buzz -!! XKEYSYMDB=/usr/share/X11/XKeysymDB -!! PUBLISH_CMD= -!! OnlineServices=Online Services -!! : -!! : -!! : integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -INTERFACE - SUBROUTINE system_initenv() BIND(C, NAME='my_initenv') - END SUBROUTINE system_initenv -END INTERFACE -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!-!type(c_ptr),bind(c,name="environ") :: c_environ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- INTEGER(kind=mode_t), BIND(c, name="FS_IRGRP") :: R_GRP INTEGER(kind=mode_t), BIND(c, name="FS_IROTH") :: R_OTH @@ -1131,9 +349,11 @@ END SUBROUTINE system_initenv ! Host names are limited to {HOST_NAME_MAX} bytes. INTEGER(kind=mode_t), BIND(c, name="FHOST_NAME_MAX") :: HOST_NAME_MAX -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + ! for system_access(3f) !integer(kind=c_int),bind(c,name="F_OK") :: F_OK !integer(kind=c_int),bind(c,name="R_OK") :: R_OK @@ -1144,100 +364,102 @@ END SUBROUTINE system_initenv INTEGER(kind=C_INT), PARAMETER :: R_OK = 4 INTEGER(kind=C_INT), PARAMETER :: W_OK = 2 INTEGER(kind=C_INT), PARAMETER :: X_OK = 1 -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + ABSTRACT INTERFACE ! mold for signal handler to be installed by system_signal SUBROUTINE handler(signum) INTEGER :: signum END SUBROUTINE handler END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + TYPE handler_pointer PROCEDURE(handler), POINTER, NOPASS :: sub END TYPE handler_pointer -INTEGER, PARAMETER :: no_of_signals = 64 ! obtained with command: kill -l + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER, PARAMETER :: no_of_signals = 64 +!! obtained with command: kill -l + TYPE(handler_pointer), DIMENSION(no_of_signals) :: handler_ptr_array -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! Contains +!---------------------------------------------------------------------------- + CONTAINS -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!> -!!##NAME -!! system_signal(3f) - [M_system:SIGNALS] install a signal handler -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_signal(sig,handler) -!! -!! integer,intent(in) :: sig -!! interface -!! subroutine handler(signum) -!! integer :: signum -!! end subroutine handler -!! end interface -!! optional :: handler -!! -!!##DESCRIPTION -!! Calling system_signal(NUMBER, HANDLER) causes user-defined -!! subroutine HANDLER to be executed when the signal NUMBER is -!! caught. The same subroutine HANDLER maybe installed to handle -!! different signals. HANDLER takes only one integer argument which -!! is assigned the signal number that is caught. See sample program -!! below for illustration. -!! -!! Calling system_signal(NUMBER) installs a do-nothing handler. This -!! is not equivalent to ignoring the signal NUMBER though, because -!! the signal can still interrupt any sleep or idle-wait. -!! -!! Note that the signals SIGKILL and SIGSTOP cannot be handled -!! this way. -!! -!! [Compare signal(2) and the GNU extension signal in gfortran.] -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_signal -!! use M_system, only : system_signal -!! implicit none -!! logical :: loop=.true. -!! integer, parameter :: SIGINT=2,SIGQUIT=3 -!! call system_signal(SIGINT,exitloop) -!! call system_signal(SIGQUIT,quit) -!! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' -!! do while(loop) -!! enddo -!! write(*,*)'Reporting from outside the infinite loop.' -!! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' -!! loop=.true. -!! call system_signal(2) -!! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' -!! do while(loop) -!! enddo -!! write(*,*)'You should never see this line when running this demo.' -!! -!! contains -!! -!! subroutine exitloop(signum) -!! integer :: signum -!! write(*,*)'Caught SIGINT. Exiting infinite loop.' -!! loop=.false. -!! end subroutine exitloop -!! -!! subroutine quit(signum) -!! integer :: signum -!! STOP 'Caught SIGQUIT. Stopping demo.' -!! end subroutine quit -!! end program demo_system_signal -!! -!!##AUTHOR -!! Somajit Dey -!! -!!##LICENSE -!! Public Domain + +!---------------------------------------------------------------------------- +! system_signal +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Install a signal handler +! +!# System_Signal +! +! Calling system_signal(NUMBER, HANDLER) causes user-defined +! subroutine HANDLER to be executed when the signal NUMBER is +! caught. The same subroutine HANDLER maybe installed to handle +! different signals. HANDLER takes only one integer argument which +! is assigned the signal number that is caught. See sample program +! below for illustration. +! +! Calling system_signal(NUMBER) installs a do-nothing handler. This +! is not equivalent to ignoring the signal NUMBER though, because +! the signal can still interrupt any sleep or idle-wait. +! +! Note that the signals SIGKILL and SIGSTOP cannot be handled +! this way. +! +! +!## Usage +! +!```fortran +! program demo_system_signal +! use M_system, only : system_signal +! implicit none +! logical :: loop=.true. +! integer, parameter :: SIGINT=2,SIGQUIT=3 +! call system_signal(SIGINT,exitloop) +! call system_signal(SIGQUIT,quit) +! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' +! do while(loop) +! enddo +! write(*,*)'Reporting from outside the infinite loop.' +! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' +! loop=.true. +! call system_signal(2) +! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' +! do while(loop) +! enddo +! write(*,*)'You should never see this line when running this demo.' +! +! contains +! +! subroutine exitloop(signum) +! integer :: signum +! write(*,*)'Caught SIGINT. Exiting infinite loop.' +! loop=.false. +! end subroutine exitloop +! +! subroutine quit(signum) +! integer :: signum +! STOP 'Caught SIGQUIT. Stopping demo.' +! end subroutine quit +! end program demo_system_signal +! ``` + SUBROUTINE system_signal(signum, handler_routine) INTEGER, INTENT(in) :: signum PROCEDURE(handler), OPTIONAL :: handler_routine @@ -1258,17 +480,25 @@ END FUNCTION c_signal !!handler_ptr_array(signum)%sub => null(handler_ptr_array(signum)%sub) handler_ptr_array(signum)%sub => NULL() END IF + c_handler = C_FUNLOC(f_handler) ret = c_signal(signum, c_handler) END SUBROUTINE system_signal +!---------------------------------------------------------------------------- +! f_handler +!---------------------------------------------------------------------------- + SUBROUTINE f_handler(signum) BIND(c) INTEGER(C_INT), INTENT(in), VALUE :: signum - if(associated(handler_ptr_array(signum)%sub))call handler_ptr_array(signum)%sub(signum) + IF (ASSOCIATED(handler_ptr_array(signum)%sub)) & + CALL handler_ptr_array(signum)%sub(signum) END SUBROUTINE f_handler -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_access(3f) - [M_system:QUERY_FILE] checks accessibility or existence of a pathname @@ -1322,6 +552,7 @@ END SUBROUTINE f_handler !! write(*,*)' is ',trim(names(i)),' executable? ', system_access(names(i),X_OK) !! enddo !! end program demo_system_access + ELEMENTAL impure FUNCTION system_access(pathname, amode) IMPLICIT NONE @@ -1350,9 +581,11 @@ END FUNCTION c_access END IF END FUNCTION system_access -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_utime(3f) - [M_system:FILE_SYSTEM] set file access and modification times @@ -1451,6 +684,7 @@ END FUNCTION system_access !! endif !! enddo !! end program demo_system_utime + FUNCTION system_utime(pathname, times) IMPLICIT NONE @@ -1485,9 +719,11 @@ END FUNCTION c_utime END IF END FUNCTION system_utime -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + FUNCTION timestamp() RESULT(epoch) USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_LONG IMPLICIT NONE @@ -1502,9 +738,11 @@ END FUNCTION c_time END INTERFACE epoch = c_time(INT(0, kind=8)) END FUNCTION timestamp -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_realpath(3f) - [M_system:FILE_SYSTEM] call realpath(3c) to resolve a pathname @@ -1573,13 +811,13 @@ END FUNCTION timestamp !! ..=>/usr/share !! *system_realpath* error for pathname NotThere:: No such file or directory !! NotThere=>NotThere -FUNCTION system_realpath(input) RESULT(string) +FUNCTION system_realpath(input) RESULT(string) ! ident_3="@(#)M_system::system_realpath(3f):call realpath(3c) to get pathname of current working directory" - CHARACTER(len=*), INTENT(in) :: input TYPE(C_PTR) :: c_output CHARACTER(len=:), ALLOCATABLE :: string + INTERFACE FUNCTION c_realpath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT @@ -1587,7 +825,7 @@ FUNCTION c_realpath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) TYPE(C_PTR) :: c_buffer END FUNCTION END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- + c_output = c_realpath(str2_carr(TRIM(input))) IF (.NOT. C_ASSOCIATED(c_output)) THEN string = CHAR(0) @@ -1595,9 +833,11 @@ FUNCTION c_realpath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) string = C2F_string(c_output) END IF END FUNCTION system_realpath -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_issock(3f) - [M_system:QUERY_FILE] checks if argument is a socket @@ -1645,11 +885,10 @@ END FUNCTION system_realpath !! write(*,*)' is ',trim(names(i)),' a socket? ', system_issock(names(i)) !! enddo !! end program demo_system_issock + FUNCTION system_issock(pathname) IMPLICIT NONE - ! ident_4="@(#)M_system::system_issock(3f): determine if pathname is a socket" - CHARACTER(len=*), INTENT(in) :: pathname LOGICAL :: system_issock @@ -1666,11 +905,12 @@ END FUNCTION c_issock ELSE system_issock = .FALSE. END IF - END FUNCTION system_issock -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_isfifo(3f) - [M_system:QUERY_FILE] checks if argument is a fifo - named pipe @@ -1718,6 +958,7 @@ END FUNCTION system_issock !! write(*,*)' is ',trim(names(i)),' a fifo(named pipe)? ', system_isfifo(names(i)) !! enddo !! end program demo_system_isfifo + ELEMENTAL impure FUNCTION system_isfifo(pathname) IMPLICIT NONE @@ -1741,9 +982,11 @@ END FUNCTION c_isfifo END IF END FUNCTION system_isfifo -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_ischr(3f) - [M_system:QUERY_FILE] checks if argument is a character device @@ -1793,6 +1036,7 @@ END FUNCTION system_isfifo !! end program demo_system_ischr !! !! Results: + ELEMENTAL impure FUNCTION system_ischr(pathname) IMPLICIT NONE @@ -1816,9 +1060,11 @@ END FUNCTION c_ischr END IF END FUNCTION system_ischr -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_isreg(3f) - [M_system:QUERY_FILE] checks if argument is a regular file @@ -1885,6 +1131,7 @@ END FUNCTION system_ischr !! filenames=pack(filenames,mask=mymask) !! write(*,'(a)')(trim(filenames(i)),i=1,size(filenames)) !! end program demo_system_isreg + ELEMENTAL impure FUNCTION system_isreg(pathname) IMPLICIT NONE @@ -1908,9 +1155,11 @@ END FUNCTION c_isreg END IF END FUNCTION system_isreg -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_islnk(3f) - [M_system:QUERY_FILE] checks if argument is a link @@ -1963,6 +1212,7 @@ END FUNCTION system_isreg !! end program demo_system_islnk !! !! Results: + ELEMENTAL impure FUNCTION system_islnk(pathname) IMPLICIT NONE @@ -1986,9 +1236,10 @@ END FUNCTION c_islnk END IF END FUNCTION system_islnk -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_isblk(3f) - [M_system:QUERY_FILE] checks if argument is a block device @@ -2038,6 +1289,7 @@ END FUNCTION system_islnk !! end program demo_system_isblk !! !! Results: + ELEMENTAL impure FUNCTION system_isblk(pathname) IMPLICIT NONE @@ -2061,9 +1313,11 @@ END FUNCTION c_isblk END IF END FUNCTION system_isblk -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_isdir(3f) - [M_system:QUERY_FILE] checks if argument is a directory path @@ -2137,11 +1391,10 @@ END FUNCTION system_isblk !! !! TEST is a directory !! EXAMPLE is a directory + ELEMENTAL impure FUNCTION system_isdir(dirname) IMPLICIT NONE - ! ident_10="@(#)M_system::system_isdir(3f): determine if DIRNAME is a directory name" - CHARACTER(len=*), INTENT(in) :: dirname LOGICAL :: system_isdir @@ -2160,9 +1413,11 @@ END FUNCTION c_isdir END IF END FUNCTION system_isdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_chown(3f) - [M_system:FILE_SYSTEM] change file owner and group @@ -2222,11 +1477,10 @@ END FUNCTION system_isdir !! endif !! enddo !! end program demo_system_chown + ELEMENTAL impure FUNCTION system_chown(dirname, owner, group) IMPLICIT NONE - ! ident_11="@(#)M_system::system_chown(3f): change owner and group of a file relative to directory file descriptor" - CHARACTER(len=*), INTENT(in) :: dirname INTEGER, INTENT(in) :: owner INTEGER, INTENT(in) :: group @@ -2250,9 +1504,11 @@ END FUNCTION c_chown END IF END FUNCTION system_chown -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_cpu_time(3f) - [M_system] get processor time by calling times(3c) @@ -2316,8 +1572,8 @@ END FUNCTION system_chown !-! real(kind=c_float) :: c_user,c_system,c_total !-! end subroutine system_cpu_time !-!end interface -SUBROUTINE system_cpu_time(total, user, system) +SUBROUTINE system_cpu_time(total, user, system) REAL, INTENT(out) :: user, system, total REAL(kind=C_FLOAT) :: c_user, c_system, c_total @@ -2333,9 +1589,10 @@ END SUBROUTINE c_cpu_time system = c_system total = c_total END SUBROUTINE system_cpu_time -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_link(3f) - [M_system:FILE_SYSTEM] link one file to another @@ -2453,9 +1710,10 @@ END FUNCTION c_link ierr = c_ierr END FUNCTION system_link -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_unlink(3f) - [M_system:FILE_SYSTEM] remove a directory @@ -2518,6 +1776,7 @@ END FUNCTION system_link !! call system_perror('*demo_system_unlink*') !! endif !! end program demo_system_unlink + ELEMENTAL impure FUNCTION system_unlink(fname) RESULT(ierr) ! ident_13="@(#)M_system::system_unlink(3f): call unlink(3c) to rm file link" @@ -2534,9 +1793,10 @@ END FUNCTION c_unlink END INTERFACE ierr = c_unlink(str2_carr(TRIM(fname))) END FUNCTION system_unlink -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_setumask(3f) - [M_system:FILE_SYSTEM] set the file mode creation umask @@ -2607,9 +1867,10 @@ INTEGER FUNCTION system_setumask(umask_value) RESULT(old_umask) old_umask = system_umask(umask_c) ! set current umask END FUNCTION system_setumask -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_getumask(3f) - [M_system:QUERY_FILE] get current umask @@ -2648,9 +1909,11 @@ INTEGER FUNCTION system_getumask() RESULT(umask_value) idum = system_umask(old_umask) ! set back to original mask umask_value = old_umask END FUNCTION system_getumask -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! perror(3f) - [M_system:ERROR_PROCESSING] print error message for last C error on stderr @@ -2689,6 +1952,7 @@ END FUNCTION system_getumask !! !! *demo_system_perror*:/NOT/THERE/OR/ANYWHERE: No such file or directory !! That is all Folks! + SUBROUTINE system_perror(prefix) USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT ! access computing environment @@ -2711,9 +1975,11 @@ END SUBROUTINE c_perror CALL c_flush() END SUBROUTINE system_perror -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_chdir(3f) - [M_system_FILE_SYSTEM] call chdir(3c) from Fortran to change working directory @@ -2778,10 +2044,9 @@ END SUBROUTINE system_perror !! /home/urbanjs/V600 !! /tmp !! *CHDIR TEST* IERR= 0 -SUBROUTINE system_chdir(path, err) +SUBROUTINE system_chdir(path, err) ! ident_15="@(#)M_system::system_chdir(3f): call chdir(3c)" - CHARACTER(len=*) :: path INTEGER, OPTIONAL, INTENT(out) :: err @@ -2798,9 +2063,11 @@ INTEGER(kind=C_INT) FUNCTION c_chdir(c_path) BIND(C, name="chdir") err = loc_err END IF END SUBROUTINE system_chdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_remove(3f) - [M_system_FILE_SYSTEM] call remove(3c) to remove file @@ -2867,10 +2134,9 @@ END SUBROUTINE system_chdir !! John S. Urban !!##LICENSE !! Public Domain -ELEMENTAL impure FUNCTION system_remove(path) RESULT(err) +ELEMENTAL impure FUNCTION system_remove(path) RESULT(err) ! ident_16="@(#)M_system::system_remove(3f): call remove(3c) to remove file" - CHARACTER(*), INTENT(in) :: path INTEGER(C_INT) :: err @@ -2884,9 +2150,11 @@ FUNCTION c_remove(c_path) BIND(c, name="remove") RESULT(c_err) !----------------------------------------------------------------------------------------------------------------------------------- err = c_remove(str2_carr(TRIM(path))) END FUNCTION system_remove -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_rename(3f) - [M_system_FILE_SYSTEM] call rename(3c) to rename a system file @@ -2990,9 +2258,11 @@ FUNCTION c_rename(c_input, c_output) BIND(c, name="rename") RESULT(c_err) !----------------------------------------------------------------------------------------------------------------------------------- ierr = c_rename(str2_carr(TRIM(input)), str2_carr(TRIM(output))) END FUNCTION system_rename -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_chmod(3f) - [M_system_FILE_SYSTEM] call chmod(3c) to change @@ -3099,6 +2369,7 @@ END FUNCTION system_rename !! John S. Urban !!##LICENSE !! Public Domain + FUNCTION system_chmod(filename, mode) RESULT(ierr) CHARACTER(len=*), INTENT(in) :: filename INTEGER, VALUE, INTENT(in) :: mode @@ -3114,9 +2385,11 @@ FUNCTION c_chmod(c_filename, c_mode) BIND(c, name="chmod") RESULT(c_err) !----------------------------------------------------------------------------------------------------------------------------------- ierr = c_chmod(str2_carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) END FUNCTION system_chmod -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_getcwd(3f) - [M_system:QUERY_FILE] call getcwd(3c) to get the pathname of the current working directory @@ -3157,10 +2430,9 @@ END FUNCTION system_chmod !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_getcwd(output, ierr) +SUBROUTINE system_getcwd(output, ierr) ! ident_18="@(#)M_system::system_getcwd(3f):call getcwd(3c) to get pathname of current working directory" - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output INTEGER, INTENT(out) :: ierr INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG @@ -3185,9 +2457,11 @@ FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) ierr = 0 END IF END SUBROUTINE system_getcwd -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_rmdir(3f) - [M_system:FILE_SYSTEM] call rmdir(3c) to remove empty directories @@ -3259,9 +2533,9 @@ FUNCTION c_rmdir(c_path) BIND(c, name="rmdir") RESULT(c_err) err = c_rmdir(str2_carr(TRIM(dirname))) IF (err .NE. 0) err = system_errno() END FUNCTION system_rmdir -!=================================================================================================================================== +!---------------------------------------------------------------------------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== +!---------------------------------------------------------------------------- !> !!##NAME !! system_mkfifo(3f) - [M_system:FILE_SYSTEM] make a FIFO special file relative to directory file descriptor @@ -3399,9 +2673,9 @@ END FUNCTION c_mkfifo c_mode = mode err = c_mkfifo(str2_carr(TRIM(pathname)), c_mode) END FUNCTION system_mkfifo -!=================================================================================================================================== +!---------------------------------------------------------------------------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== +!---------------------------------------------------------------------------- !> !!##NAME !! system_mkdir(3f) - [M_system:FILE_SYSTEM] call mkdir(3c) to create a new directory @@ -3492,12 +2766,15 @@ END SUBROUTINE my_mkdir END IF ierr = err ! c_int to default integer kind END FUNCTION system_mkdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_opendir(3f) - [M_system:QUERY_FILE] open directory stream by calling opendir(3c) @@ -3585,6 +2862,7 @@ END FUNCTION system_mkdir !! John S. Urban !!##LICENSE !! Public Domain + SUBROUTINE system_opendir(dirname, dir, ierr) CHARACTER(len=*), INTENT(in) :: dirname TYPE(C_PTR) :: dir @@ -3606,9 +2884,10 @@ END FUNCTION c_opendir END IF END SUBROUTINE system_opendir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_readdir(3f) - [M_system:QUERY_FILE] read a directory using readdir(3c) @@ -3710,9 +2989,10 @@ END SUBROUTINE c_readdir ierr = ierr_local END SUBROUTINE system_readdir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_rewinddir(3f) - [M_system:QUERY_FILE] call rewinddir(3c) to rewind directory stream @@ -3776,9 +3056,10 @@ END SUBROUTINE c_rewinddir CALL c_rewinddir(dir) END SUBROUTINE system_rewinddir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_closedir(3f) - [M_system:QUERY_FILE] close a directory stream by calling closedir(3c) @@ -3854,9 +3135,10 @@ END FUNCTION c_closedir END IF END SUBROUTINE system_closedir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_putenv(3f) - [M_system:ENVIRONMENT] set environment variable from Fortran by calling putenv(3c) @@ -3956,9 +3238,10 @@ INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") IF (PRESENT(err)) err = loc_err END SUBROUTINE system_putenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_getenv(3f) - [M_system:ENVIRONMENT] get environment variable @@ -4031,9 +3314,10 @@ FUNCTION system_getenv(name, default) RESULT(VALUE) IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default END FUNCTION system_getenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! set_environment_variable(3f) - [M_system:ENVIRONMENT] call setenv(3c) to set environment variable @@ -4113,9 +3397,10 @@ INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) IF (PRESENT(STATUS)) STATUS = loc_err END SUBROUTINE set_environment_variable -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- !> !!##NAME !! system_clearenv(3f) - [M_system:ENVIRONMENT] clear environment by calling clearenv(3c) @@ -4209,9 +3494,11 @@ END SUBROUTINE system_clearenv !-- endif !-- !--end subroutine system_clearenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_unsetenv(3f) - [M_system:ENVIRONMENT] delete an environment variable by calling unsetenv(3c) @@ -4282,9 +3569,11 @@ INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") END IF END SUBROUTINE system_unsetenv -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_readenv(3f) - [M_system:ENVIRONMENT] step thru and read environment table @@ -4339,6 +3628,7 @@ END SUBROUTINE system_unsetenv !! John S. Urban !!##LICENSE !! Public Domain + FUNCTION system_readenv() RESULT(string) ! ident_27="@(#)M_system::system_readenv(3f): read next entry from environment table" @@ -4359,9 +3649,10 @@ END SUBROUTINE c_readenv string = TRIM(arr2str(c_buff)) END FUNCTION system_readenv -!=================================================================================================================================== + +!---------------------------------------------------------------------------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== +!---------------------------------------------------------------------------- !> !!##NAME !! fileglob(3f) - [M_system:QUERY_FILE] Read output of an ls(1) command from Fortran @@ -4440,9 +3731,9 @@ SUBROUTINE fileglob(glob, list) ! NON-PORTABLE AT THIS POINT. REQUIRES ls(1) com END DO CLOSE (iotmp, status='delete', iostat=ios) ! close and delete scratch file END SUBROUTINE fileglob -!=================================================================================================================================== +!---------------------------------------------------------------------------- !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== +!---------------------------------------------------------------------------- !> !!##NAME !! system_uname(3f) - [M_system] call a C wrapper that calls uname(3c) to get current system information from Fortran @@ -4511,9 +3802,11 @@ END SUBROUTINE system_uname_c CALL system_uname_c(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) END SUBROUTINE system_uname -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_gethostname(3f) - [M_system:QUERY] get name of current host @@ -4553,6 +3846,7 @@ END SUBROUTINE system_uname !! John S. Urban !!##LICENSE !! Public Domain + SUBROUTINE system_gethostname(NAME, IERR) IMPLICIT NONE @@ -4579,9 +3873,11 @@ END FUNCTION system_gethostname_c NAME = TRIM(arr2str(C_BUFF)) END SUBROUTINE system_gethostname -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_getlogin(3f) - [M_system:QUERY] get login name @@ -4663,9 +3959,11 @@ END FUNCTION c_getlogin END IF END FUNCTION system_getlogin -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_perm(3f) - [M_system:QUERY_FILE] get file type and permission as a string @@ -4747,9 +4045,11 @@ END FUNCTION c_perm END IF END FUNCTION system_perm -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_getgrgid(3f) - [M_system:QUERY] get groupd name associated with a GID @@ -4820,9 +4120,11 @@ END FUNCTION c_getgrgid END IF !----------------------------------------------------------------------------------------------------------------------------------- END FUNCTION system_getgrgid -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_getpwuid(3f) - [M_system:QUERY] get login name associated with a UID @@ -4892,9 +4194,11 @@ END FUNCTION c_getpwuid END IF !----------------------------------------------------------------------------------------------------------------------------------- END FUNCTION system_getpwuid -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + PURE FUNCTION arr2str(array) RESULT(string) ! ident_31="@(#)M_system::arr2str(3fp): function copies null-terminated char array to string" @@ -4913,9 +4217,11 @@ PURE FUNCTION arr2str(array) RESULT(string) END DO END FUNCTION arr2str -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + PURE FUNCTION str2_carr(string) RESULT(array) ! ident_32="@(#)M_system::str2_carr(3fp): function copies string to null terminated char array" @@ -4930,9 +4236,11 @@ PURE FUNCTION str2_carr(string) RESULT(array) array(i:i) = C_NULL_CHAR END FUNCTION str2_carr -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + FUNCTION C2F_string(c_string_pointer) RESULT(f_string) ! gets a C string (pointer), and returns the corresponding Fortran string up to 4096(max_len) characters; @@ -4969,9 +4277,11 @@ FUNCTION C2F_string(c_string_pointer) RESULT(f_string) ALLOCATE (CHARACTER(len=length) :: f_string) f_string = aux_string(1:length) END FUNCTION C2F_string -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! SYSTEM_STAT - [M_system:QUERY_FILE] Get file status information @@ -5106,6 +4416,7 @@ END FUNCTION C2F_string !! John S. Urban !!##LICENSE !! Public Domain + SUBROUTINE system_stat(pathname, values, ierr) IMPLICIT NONE @@ -5135,12 +4446,11 @@ END SUBROUTINE c_stat ierr = cierr END IF END SUBROUTINE system_stat -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !> !!##NAME !! system_dir(3f) - [M_io] return filenames in a directory matching specified wildcard string @@ -5184,6 +4494,7 @@ END SUBROUTINE system_stat !! !!##LICENSE !! Public Domain + FUNCTION system_dir(directory, pattern) !use M_system, only : system_opendir, system_readdir, system_rewinddir, system_closedir USE ISO_C_BINDING @@ -5233,14 +4544,14 @@ FUNCTION system_dir(directory, pattern) END IF CALL system_closedir(dir, ierr) !--- close directory stream END FUNCTION system_dir -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + ! copied from M_strings.ff to make stand-alone github version FUNCTION matchw(tame, wild) - ! ident_34="@(#)M_strings::matchw(3f): function compares text strings, one of which can have wildcards ('*' or '?')." - LOGICAL :: matchw CHARACTER(len=*) :: tame ! A string without wildcards CHARACTER(len=*) :: wild ! A (potentially) corresponding string with wildcards @@ -5328,9 +4639,11 @@ FUNCTION matchw(tame, wild) END IF END DO END FUNCTION matchw -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + !>NAME !! !! anyinteger_to_64bit(3f) - [M_anything] convert integer any kind to integer(kind=int64) @@ -5402,7 +4715,7 @@ END FUNCTION matchw !! John S. Urban !!LICENSE !! Public Domain -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + PURE ELEMENTAL FUNCTION anyinteger_to_64bit(intin) RESULT(ii38) USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT !! ,input_unit,output_unit IMPLICIT NONE @@ -5421,7 +4734,9 @@ PURE ELEMENTAL FUNCTION anyinteger_to_64bit(intin) RESULT(ii38) !stop 'ERROR: *anyinteger_to_64* unknown integer type' END SELECT END FUNCTION anyinteger_to_64bit -!=================================================================================================================================== -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! -!=================================================================================================================================== + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE System_Method diff --git a/src/submodules/System/CMakeLists.txt b/src/submodules/System/CMakeLists.txt new file mode 100644 index 000000000..411f9b180 --- /dev/null +++ b/src/submodules/System/CMakeLists.txt @@ -0,0 +1,26 @@ +# This program is a part of EASIFEM library +# Expandable And Scalable Infrastructure for Finite Element Methods +# htttps://www.easifem.com +# Vikas Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE + ${src_path}/System_Method@GetMethods.F90 + ${src_path}/System_Method@SetMethods.F90 + ${src_path}/System_Method@EnquiryMethods.F90 +) diff --git a/src/submodules/System/src/System_Method@EnquiryMethods.F90 b/src/submodules/System/src/System_Method@EnquiryMethods.F90 new file mode 100644 index 000000000..e69de29bb diff --git a/src/submodules/System/src/System_Method@GetMethods.F90 b/src/submodules/System/src/System_Method@GetMethods.F90 new file mode 100644 index 000000000..c20e3929c --- /dev/null +++ b/src/submodules/System/src/System_Method@GetMethods.F90 @@ -0,0 +1,28 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(System_Method) GetMethods +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE GetMethods diff --git a/src/submodules/System/src/System_Method@SetMethods.F90 b/src/submodules/System/src/System_Method@SetMethods.F90 new file mode 100644 index 000000000..e69de29bb From cd11e869fcc9054bb377095c53d3f7eb94866431 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Fri, 6 Feb 2026 11:17:02 +0900 Subject: [PATCH 3/6] System_Method updating structure --- fortitude.toml | 10 +- src/modules/System/src/SystemInterface.F90 | 111 +- src/modules/System/src/System_Method.F90 | 2663 +++++------------ src/submodules/CMakeLists.txt | 3 + src/submodules/System/CMakeLists.txt | 10 +- .../src/System_Method@EnquiryMethods.F90 | 200 ++ .../src/System_Method@EnviormentMethods.F90 | 180 ++ .../src/System_Method@EnvironmentMethods.F90 | 50 + .../System/src/System_Method@FileMethods.F90 | 414 +++ .../System/src/System_Method@GetMethods.F90 | 278 +- .../System/src/System_Method@SetMethods.F90 | 0 .../src/System_Method@SignalMethods.F90 | 39 + .../src/System_Method@UtilityMethods.F90 | 219 ++ 13 files changed, 2227 insertions(+), 1950 deletions(-) create mode 100644 src/submodules/System/src/System_Method@EnviormentMethods.F90 create mode 100644 src/submodules/System/src/System_Method@EnvironmentMethods.F90 create mode 100644 src/submodules/System/src/System_Method@FileMethods.F90 delete mode 100644 src/submodules/System/src/System_Method@SetMethods.F90 create mode 100644 src/submodules/System/src/System_Method@SignalMethods.F90 create mode 100644 src/submodules/System/src/System_Method@UtilityMethods.F90 diff --git a/fortitude.toml b/fortitude.toml index f3f158533..b7dd015fd 100644 --- a/fortitude.toml +++ b/fortitude.toml @@ -1,10 +1,14 @@ [check] preview = true -select = ["C", "E", "S", "MOD", "OB"] -# ignore = [] +select = ["C", "E", "S", "MOD"] +ignore = [ + "superfluous-implicit-none", + "implicit-external-procedures", + "interface-implicit-typing", +] file-extensions = ["f90", "F90"] line-length = 78 -fix = false +fix = true # output-format = "full" # show-fixes = false # unsafe-fixes = true diff --git a/src/modules/System/src/SystemInterface.F90 b/src/modules/System/src/SystemInterface.F90 index 2273318a5..fdf1269df 100644 --- a/src/modules/System/src/SystemInterface.F90 +++ b/src/modules/System/src/SystemInterface.F90 @@ -17,7 +17,7 @@ MODULE SystemInterface USE ISO_C_BINDING, ONLY: C_INT, C_SIZE_T, C_INTPTR_T, C_LONG -USE ISO_C_BINDING, ONLY: C_PTR +USE ISO_C_BINDING, ONLY: C_PTR, C_FUNPTR, C_CHAR, C_LONG IMPLICIT NONE PRIVATE @@ -42,9 +42,16 @@ MODULE SystemInterface PUBLIC :: System_Getppid PUBLIC :: System_Umask PUBLIC :: System_Rand -PUBLIC :: C_Flush PUBLIC :: System_Initenv +PUBLIC :: C_Flush +PUBLIC :: C_Signal +PUBLIC :: C_Access +PUBLIC :: C_Utime +PUBLIC :: C_RealPath +PUBLIC :: C_Issock +PUBLIC :: C_Time + !---------------------------------------------------------------------------- ! System_Alarm !---------------------------------------------------------------------------- @@ -292,10 +299,10 @@ END SUBROUTINE System_Srand !``` INTERFACE - FUNCTION System_Kill(c_pid, c_signal) BIND(c, name="kill") RESULT(c_ierr) + FUNCTION System_Kill(pid, signal) BIND(c, name="kill") RESULT(c_ierr) IMPORT C_INT - INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_pid - INTEGER(kind=C_INT), VALUE, INTENT(in) :: c_signal + INTEGER(kind=C_INT), VALUE, INTENT(in) :: pid + INTEGER(kind=C_INT), VALUE, INTENT(in) :: signal INTEGER(kind=C_INT) :: c_ierr END FUNCTION System_Kill END INTERFACE @@ -708,15 +715,6 @@ INTEGER(kind=C_INT) FUNCTION System_Rand() BIND(C, name="rand") END FUNCTION System_Rand END INTERFACE -!---------------------------------------------------------------------------- -! C_Flush -!---------------------------------------------------------------------------- - -INTERFACE - SUBROUTINE C_Flush() BIND(C, name="my_flush") - END SUBROUTINE C_Flush -END INTERFACE - !---------------------------------------------------------------------------- ! System_Initenv !---------------------------------------------------------------------------- @@ -758,6 +756,91 @@ SUBROUTINE System_Initenv() BIND(C, NAME='my_initenv') END SUBROUTINE System_Initenv END INTERFACE +!---------------------------------------------------------------------------- +! C_Flush +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_Flush() BIND(C, name="my_flush") + END SUBROUTINE C_Flush +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Signal +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Signal(signal, sighandler) BIND(c, name='signal') + IMPORT :: C_INT, C_FUNPTR + INTEGER(C_INT), VALUE, INTENT(in) :: signal + TYPE(C_FUNPTR), VALUE, INTENT(in) :: sighandler + TYPE(C_FUNPTR) :: C_Signal + END FUNCTION C_Signal +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Access +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Access(c_pathname, c_amode) BIND(C, name="my_access") & + RESULT(c_ierr) + IMPORT :: C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) + INTEGER(kind=C_INT), VALUE :: c_amode + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Access +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Utime +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Utime(c_pathname, c_times) BIND(C, name="my_utime") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) + INTEGER(kind=C_INT), INTENT(in) :: c_times(2) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Utime +END INTERFACE + +!---------------------------------------------------------------------------- +! System_RealPath +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_RealPath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) + IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) + TYPE(C_PTR) :: c_buffer + END FUNCTION C_RealPath +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Issock +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Issock(pathname) BIND(C, name="my_issock") RESULT(c_ierr) + IMPORT :: C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Issock +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Time +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Time(tloc) BIND(c, name='time') + IMPORT :: C_LONG + INTEGER(kind=C_LONG), INTENT(in), VALUE :: tloc + INTEGER(kind=C_LONG) :: C_Time + END FUNCTION C_Time +END INTERFACE + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/System/src/System_Method.F90 b/src/modules/System/src/System_Method.F90 index 57cb13834..2c4d44d64 100755 --- a/src/modules/System/src/System_Method.F90 +++ b/src/modules/System/src/System_Method.F90 @@ -9,7 +9,7 @@ ! We would like to thank the original author Urban Jost for creating ! This useful module. -!> author: Vikas Sharma, Ph. D. +!> author: John S. Urban ! date: 2026-02-04 ! summary: Fortran interface to C system interface ! @@ -173,7 +173,7 @@ MODULE System_Method USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR -USE ISO_C_BINDING, ONLY: C_PTR, c_f_pointer, C_NULL_CHAR, C_NULL_PTR +USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER, C_NULL_CHAR, C_NULL_PTR USE, INTRINSIC :: ISO_C_BINDING USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT8, INT16, INT32, INT64 !!, real32, real64, real128, dp=>real128 @@ -321,11 +321,6 @@ MODULE System_Method ! !---------------------------------------------------------------------------- -INTERFACE - SUBROUTINE c_flush() BIND(C, name="my_flush") - END SUBROUTINE c_flush -END INTERFACE - integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable !---------------------------------------------------------------------------- @@ -392,12 +387,6 @@ END SUBROUTINE handler TYPE(handler_pointer), DIMENSION(no_of_signals) :: handler_ptr_array -!---------------------------------------------------------------------------- -! Contains -!---------------------------------------------------------------------------- - -CONTAINS - !---------------------------------------------------------------------------- ! system_signal !---------------------------------------------------------------------------- @@ -426,318 +415,240 @@ END SUBROUTINE handler !## Usage ! !```fortran -! program demo_system_signal -! use M_system, only : system_signal -! implicit none -! logical :: loop=.true. -! integer, parameter :: SIGINT=2,SIGQUIT=3 -! call system_signal(SIGINT,exitloop) -! call system_signal(SIGQUIT,quit) -! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' -! do while(loop) -! enddo -! write(*,*)'Reporting from outside the infinite loop.' -! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' -! loop=.true. -! call system_signal(2) -! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' -! do while(loop) -! enddo -! write(*,*)'You should never see this line when running this demo.' -! -! contains -! -! subroutine exitloop(signum) -! integer :: signum -! write(*,*)'Caught SIGINT. Exiting infinite loop.' -! loop=.false. -! end subroutine exitloop -! -! subroutine quit(signum) -! integer :: signum -! STOP 'Caught SIGQUIT. Stopping demo.' -! end subroutine quit -! end program demo_system_signal +! program demo_system_signal +! use M_system, only : system_signal +! implicit none +! logical :: loop=.true. +! integer, parameter :: SIGINT=2,SIGQUIT=3 +! call system_signal(SIGINT,exitloop) +! call system_signal(SIGQUIT,quit) +! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' +! do while(loop) +! enddo +! write(*,*)'Reporting from outside the infinite loop.' +! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' +! loop=.true. +! call system_signal(2) +! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' +! do while(loop) +! enddo +! write(*,*)'You should never see this line when running this demo.' +! +! contains +! +! subroutine exitloop(signum) +! integer :: signum +! write(*,*)'Caught SIGINT. Exiting infinite loop.' +! loop=.false. +! end subroutine exitloop +! +! subroutine quit(signum) +! integer :: signum +! STOP 'Caught SIGQUIT. Stopping demo.' +! end subroutine quit +! end program demo_system_signal ! ``` -SUBROUTINE system_signal(signum, handler_routine) - INTEGER, INTENT(in) :: signum - PROCEDURE(handler), OPTIONAL :: handler_routine - TYPE(C_FUNPTR) :: ret, c_handler - - INTERFACE - FUNCTION c_signal(signal, sighandler) BIND(c, name='signal') - IMPORT :: C_INT, C_FUNPTR - INTEGER(C_INT), VALUE, INTENT(in) :: signal - TYPE(C_FUNPTR), VALUE, INTENT(in) :: sighandler - TYPE(C_FUNPTR) :: c_signal - END FUNCTION c_signal - END INTERFACE - - IF (PRESENT(handler_routine)) THEN - handler_ptr_array(signum)%sub => handler_routine - ELSE - !!handler_ptr_array(signum)%sub => null(handler_ptr_array(signum)%sub) - handler_ptr_array(signum)%sub => NULL() - END IF - - c_handler = C_FUNLOC(f_handler) - ret = c_signal(signum, c_handler) -END SUBROUTINE system_signal +INTERFACE + MODULE SUBROUTINE System_Signal(signum, handler_routine) + INTEGER, INTENT(in) :: signum + PROCEDURE(handler), OPTIONAL :: handler_routine + TYPE(C_FUNPTR) :: ret, c_handler + END SUBROUTINE System_Signal +END INTERFACE !---------------------------------------------------------------------------- -! f_handler +! System_Access !---------------------------------------------------------------------------- -SUBROUTINE f_handler(signum) BIND(c) - INTEGER(C_INT), INTENT(in), VALUE :: signum - IF (ASSOCIATED(handler_ptr_array(signum)%sub)) & - CALL handler_ptr_array(signum)%sub(signum) -END SUBROUTINE f_handler - -!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Check accessibility or existence of a pathname ! -!---------------------------------------------------------------------------- +!# System_Access +! +! +!The system_access(3f) function checks pathname existence and access +!permissions. The function checks the pathname for accessibility +!according to the bit pattern contained in amode, using the real user +!ID in place of the effective user ID and the real group ID in place +!of the effective group ID. +! +!The value of amode is either the bitwise-inclusive OR of the access +!permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). +! +!- pathname: a character string representing a directory pathname. +! Trailing spaces are ignored. +!- amode: bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. +!- Return value: If not true an error occurred or +! the requested access is not granted +! +! +!## Examples +! +! Check if filename is accessible +! +!```fortran +! program demo_system_access +! use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK +! implicit none +! integer :: i +! character(len=80),parameter :: names(*)=[ & +! '/usr/bin/bash ', & +! '/tmp/NOTTHERE ', & +! '/usr/local ', & +! '. ', & +! 'PROBABLY_NOT '] +! do i=1,size(names) +! write(*,*)' does ',trim(names(i)),' exist? ', & +! system_access(names(i),F_OK) +! +! write(*,*)' is ',trim(names(i)),' readable? ', & +! system_access(names(i),R_OK) +! +! write(*,*)' is ',trim(names(i)),' writable? ', & +! system_access(names(i),W_OK) +! +! write(*,*)' is ',trim(names(i)),' executable? ', & +! system_access(names(i),X_OK) +! +! enddo +! end program demo_system_access +!``` -!> -!!##NAME -!! system_access(3f) - [M_system:QUERY_FILE] checks accessibility or existence of a pathname -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_access(pathname,amode) -!! -!! character(len=*),intent(in) :: pathname -!! integer,intent(in) :: amode -!! -!!##DESCRIPTION -!! -!! The system_access(3f) function checks pathname existence and access -!! permissions. The function checks the pathname for accessibility -!! according to the bit pattern contained in amode, using the real user -!! ID in place of the effective user ID and the real group ID in place -!! of the effective group ID. -!! -!! The value of amode is either the bitwise-inclusive OR of the access -!! permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). -!! -!!##OPTIONS -!! pathname a character string representing a directory pathname. Trailing spaces are ignored. -!! amode bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. -!! -!!##RETURN VALUE -!! If not true an error occurred or the requested access is not granted -!! -!!##EXAMPLE -!! -!! check if filename is accessible -!! -!! Sample program: -!! -!! program demo_system_access -!! use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/usr/bin/bash ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' does ',trim(names(i)),' exist? ', system_access(names(i),F_OK) -!! write(*,*)' is ',trim(names(i)),' readable? ', system_access(names(i),R_OK) -!! write(*,*)' is ',trim(names(i)),' writable? ', system_access(names(i),W_OK) -!! write(*,*)' is ',trim(names(i)),' executable? ', system_access(names(i),X_OK) -!! enddo -!! end program demo_system_access - -ELEMENTAL impure FUNCTION system_access(pathname, amode) - IMPLICIT NONE - -! ident_1="@(#)M_system::system_access(3f): checks accessibility or existence of a pathname" - - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in) :: amode - LOGICAL :: system_access - - INTERFACE - function c_access(c_pathname,c_amode) bind (C,name="my_access") result (c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) - INTEGER(kind=C_INT), VALUE :: c_amode - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_access - END INTERFACE - - IF (c_access(str2_carr(TRIM(pathname)), INT(amode, kind=C_INT)) .EQ. 0) THEN - system_access = .TRUE. - ELSE - system_access = .FALSE. - !!if(system_errno().ne.0)then - !! call perror('*system_access*') - !!endif - END IF - -END FUNCTION system_access +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Access(pathname, amode) + CHARACTER(len=*), INTENT(IN) :: pathname + INTEGER, INTENT(IN) :: amode + LOGICAL :: System_Access + END FUNCTION System_Access +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Utime !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_utime(3f) - [M_system:FILE_SYSTEM] set file access and modification times -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function utime(pathname,times) -!! -!! character(len=*),intent(in) :: pathname -!! integer,intent(in),optional :: times(2) -!! logical :: utime -!! -!!##DESCRIPTION -!! The system_utime(3f) function sets the access and modification -!! times of the file named by the path argument by calling utime(3c). -!! -!! If times() is not present the access and modification times of -!! the file shall be set to the current time. -!! -!! To use system_utime(3f) the effective user ID of the process must -!! match the owner of the file, or the process has to have write -!! permission to the file or have appropriate privileges, -!! -!!##OPTIONS -!! times If present, the values will be interpreted as the access -!! and modification times as Unix Epoch values. That is, -!! they are times measured in seconds since the Unix Epoch. -!! -!! pathname name of the file whose access and modification times -!! are to be updated. -!! -!!##RETURN VALUE -!! Upon successful completion .TRUE. is returned. Otherwise, -!! .FALSE. is returned and errno shall be set to indicate the error, -!! and the file times remain unaffected. -!! -!!##ERRORS -!! The underlying utime(3c) function fails if: -!! -!! EACCES Search permission is denied by a component of the path -!! prefix; or the times argument is a null pointer and the -!! effective user ID of the process does not match the owner -!! of the file, the process does not have write permission -!! for the file, and the process does not have appropriate -!! privileges. -!! -!! ELOOP A loop exists in symbolic links encountered during -!! resolution of the path argument. -!! -!! ENAMETOOLONG The length of a component of a pathname is longer -!! than {NAME_MAX}. -!! -!! ENOENT A component of path does not name an existing file -!! or path is an empty string. -!! -!! ENOTDIR A component of the path prefix names an existing file -!! that is neither a directory nor a symbolic link to a -!! directory, or the path argument contains at least one -!! non- character and ends with one or more trailing -!! characters and the last pathname component -!! names an existing file that is neither a directory nor -!! a symbolic link to a directory. -!! -!! EPERM The times argument is not a null pointer and the effective -!! user ID of the calling process does not match the owner -!! of the file and the calling process does not have -!! appropriate privileges. -!! -!! EROFS The file system containing the file is read-only. -!! -!! The utime() function may fail if: -!! -!! ELOOP More than {SYMLOOP_MAX} symbolic links were encountered -!! during resolution of the path argument. -!! -!! ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, or -!! pathname resolution of a symbolic link produced -!! an intermediate result with a length that exceeds -!! {PATH_MAX}. -!! -!!##EXAMPLES -!! -!! Sample program -!! -!! program demo_system_utime -!! use M_system, only : system_utime, system_perror -!! implicit none -!! character(len=4096) :: pathname -!! integer :: times(2) -!! integer :: i -!! do i=1,command_argument_count() -!! call get_command_argument(i, pathname) -!! if(.not.system_utime(pathname,times))then -!! call system_perror('*demo_system_utime*') -!! endif -!! enddo -!! end program demo_system_utime - -FUNCTION system_utime(pathname, times) - IMPLICIT NONE - -! ident_2="@(#)M_system::system_utime(3f): set access and modification times of a pathname" - - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in), OPTIONAL :: times(2) - INTEGER :: times_local(2) - LOGICAL :: system_utime - -!-! int my_utime(const char *path, int times[2]) - INTERFACE - FUNCTION c_utime(c_pathname, c_times) BIND(C, name="my_utime") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_pathname(*) - INTEGER(kind=C_INT), INTENT(in) :: c_times(2) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_utime - END INTERFACE - IF (PRESENT(times)) THEN - times_local = times - ELSE - times_local = timestamp() - END IF - if(c_utime(str2_carr(trim(pathname)),int(times_local,kind=c_int)).eq.0)then - system_utime = .TRUE. - ELSE - system_utime = .FALSE. - !!if(system_errno().ne.0)then - !! call perror('*system_utime*') - !!endif - END IF - -END FUNCTION system_utime - -!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Set file access and modification times ! -!---------------------------------------------------------------------------- +!# System_Utime +! +! The system_utime(3f) function sets the access and modification +! times of the file named by the path argument by calling utime(3c). +! +! If times() is not present the access and modification times of +! the file shall be set to the current time. +! +! To use system_utime(3f) the effective user ID of the process must +! match the owner of the file, or the process has to have write +! permission to the file or have appropriate privileges, +! +!## Arguments +! +!### times +! +!If present, the values will be interpreted as the access +!and modification times as Unix Epoch values. That is, +!they are times measured in seconds since the Unix Epoch. +! +!### pathname +! +!name of the file whose access and modification times are to be updated. +! +!## Return values +! +!Upon successful completion .TRUE. is returned. Otherwise, +!.FALSE. is returned and errno shall be set to indicate the error, +!and the file times remain unaffected. +! +!## Errors +! +!The underlying utime(3c) function fails if: +! +!### EACCES +! +! Search permission is denied by a component of the path +! prefix; or the times argument is a null pointer and the +! effective user ID of the process does not match the owner +! of the file, the process does not have write permission +! for the file, and the process does not have appropriate +! privileges. +! +!### ELOOP +! +! A loop exists in symbolic links encountered during +! resolution of the path argument. +! +!### ENAMETOOLONG +! +! The length of a component of a pathname is longer than {NAME_MAX}. +! +! +!### ENOENT +! +! A component of path does not name an existing file or path is an +! empty string. +! +!### ENOTDIR +! +! A component of the path prefix names an existing file +! that is neither a directory nor a symbolic link to a +! directory, or the path argument contains at least one +! non- character and ends with one or more trailing +! characters and the last pathname component +! names an existing file that is neither a directory nor +! a symbolic link to a directory. +! +!### EPERM +! +! The times argument is not a null pointer and the effective +! user ID of the calling process does not match the owner +! of the file and the calling process does not have +! appropriate privileges. +! +!### EROFS +! +! The file system containing the file is read-only. +! +!## Note +! +! The utime() function may fail if: +! +!- ELOOP More than {SYMLOOP_MAX} symbolic links were encountered +!during resolution of the path argument. +! +!- ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, or +! pathname resolution of a symbolic link produced +! an intermediate result with a length that exceeds +! {PATH_MAX}. +! +! +!## Usage +! +!```fortran +! program demo_system_utime +! use M_system, only : system_utime, system_perror +! implicit none +! character(len=4096) :: pathname +! integer :: times(2) +! integer :: i +! do i=1,command_argument_count() +! call get_command_argument(i, pathname) +! if(.not.system_utime(pathname,times))then +! call system_perror('*demo_system_utime*') +! endif +! enddo +! end program demo_system_utime +!``` -FUNCTION timestamp() RESULT(epoch) - USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_LONG - IMPLICIT NONE - INTEGER(kind=8) :: epoch - INTERFACE - ! time_t time(time_t *tloc) - FUNCTION c_time(tloc) BIND(c, name='time') - IMPORT :: C_LONG - INTEGER(kind=C_LONG), INTENT(in), VALUE :: tloc - INTEGER(kind=C_LONG) :: c_time - END FUNCTION c_time - END INTERFACE - epoch = c_time(INT(0, kind=8)) -END FUNCTION timestamp +INTERFACE + MODULE FUNCTION system_utime(pathname, times) + CHARACTER(len=*), INTENT(in) :: pathname + INTEGER, INTENT(in), OPTIONAL :: times(2) + LOGICAL :: system_utime + END FUNCTION System_Utime +END INTERFACE !---------------------------------------------------------------------------- ! @@ -812,27 +723,12 @@ END FUNCTION timestamp !! *system_realpath* error for pathname NotThere:: No such file or directory !! NotThere=>NotThere -FUNCTION system_realpath(input) RESULT(string) -! ident_3="@(#)M_system::system_realpath(3f):call realpath(3c) to get pathname of current working directory" - CHARACTER(len=*), INTENT(in) :: input - TYPE(C_PTR) :: c_output - CHARACTER(len=:), ALLOCATABLE :: string - - INTERFACE - FUNCTION c_realpath(c_input) BIND(c, name="my_realpath") RESULT(c_buffer) - IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) - TYPE(C_PTR) :: c_buffer - END FUNCTION - END INTERFACE - - c_output = c_realpath(str2_carr(TRIM(input))) - IF (.NOT. C_ASSOCIATED(c_output)) THEN - string = CHAR(0) - ELSE - string = C2F_string(c_output) - END IF -END FUNCTION system_realpath +INTERFACE + MODULE FUNCTION system_realpath(input) RESULT(string) + CHARACTER(len=*), INTENT(in) :: input + CHARACTER(len=:), ALLOCATABLE :: string + END FUNCTION system_realpath +END INTERFACE !---------------------------------------------------------------------------- ! @@ -886,26 +782,56 @@ END FUNCTION system_realpath !! enddo !! end program demo_system_issock -FUNCTION system_issock(pathname) - IMPLICIT NONE -! ident_4="@(#)M_system::system_issock(3f): determine if pathname is a socket" - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_issock - - INTERFACE - FUNCTION c_issock(pathname) BIND(C, name="my_issock") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_issock - END INTERFACE - - IF (c_issock(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_issock = .TRUE. - ELSE - system_issock = .FALSE. - END IF -END FUNCTION system_issock +INTERFACE + MODULE FUNCTION System_Issock(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: System_Issock + END FUNCTION System_Issock +END INTERFACE + +!---------------------------------------------------------------------------- +! C2F_String@UtilityMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: converts c string to fortran string + +INTERFACE + MODULE FUNCTION C2F_String(c_string_pointer) RESULT(f_string) + TYPE(C_PTR), INTENT(in) :: c_string_pointer + CHARACTER(len=:), ALLOCATABLE :: f_string + END FUNCTION C2F_String +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Str2_Carr + +INTERFACE + MODULE PURE FUNCTION str2_carr(string) RESULT(array) + CHARACTER(len=*), INTENT(in) :: string + CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) + END FUNCTION str2_carr +END INTERFACE + +!---------------------------------------------------------------------------- +! TimeStamp +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Time stamp method + +INTERFACE + MODULE FUNCTION TimeStamp() RESULT(epoch) + INTEGER(kind=8) :: epoch + END FUNCTION TimeStamp +END INTERFACE !---------------------------------------------------------------------------- ! @@ -959,29 +885,12 @@ END FUNCTION system_issock !! enddo !! end program demo_system_isfifo -ELEMENTAL impure FUNCTION system_isfifo(pathname) - IMPLICIT NONE - -! ident_5="@(#)M_system::system_isfifo(3f): determine if pathname is a fifo(named pipe)" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isfifo - - INTERFACE - FUNCTION c_isfifo(pathname) BIND(C, name="my_isfifo") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isfifo - END INTERFACE - - IF (c_isfifo(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isfifo = .TRUE. - ELSE - system_isfifo = .FALSE. - END IF - -END FUNCTION system_isfifo +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Isfifo(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: System_Isfifo + END FUNCTION System_Isfifo +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1037,29 +946,12 @@ END FUNCTION system_isfifo !! !! Results: -ELEMENTAL impure FUNCTION system_ischr(pathname) - IMPLICIT NONE - -! ident_6="@(#)M_system::system_ischr(3f): determine if pathname is a link" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_ischr - - INTERFACE - FUNCTION c_ischr(pathname) BIND(C, name="my_ischr") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_ischr - END INTERFACE - - IF (c_ischr(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_ischr = .TRUE. - ELSE - system_ischr = .FALSE. - END IF - -END FUNCTION system_ischr +INTERFACE + MODULE ELEMENTAL impure FUNCTION System_Ischr(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: System_Ischr + END FUNCTION System_Ischr +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1132,29 +1024,12 @@ END FUNCTION system_ischr !! write(*,'(a)')(trim(filenames(i)),i=1,size(filenames)) !! end program demo_system_isreg -ELEMENTAL impure FUNCTION system_isreg(pathname) - IMPLICIT NONE - -! ident_7="@(#)M_system::system_isreg(3f): determine if pathname is a regular file" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isreg - - INTERFACE - FUNCTION c_isreg(pathname) BIND(C, name="my_isreg") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isreg - END INTERFACE - - IF (c_isreg(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isreg = .TRUE. - ELSE - system_isreg = .FALSE. - END IF - -END FUNCTION system_isreg +INTERFACE + MODULE ELEMENTAL impure FUNCTION system_isreg(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: system_isreg + END FUNCTION system_isreg +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1213,29 +1088,12 @@ END FUNCTION system_isreg !! !! Results: -ELEMENTAL impure FUNCTION system_islnk(pathname) - IMPLICIT NONE - -! ident_8="@(#)M_system::system_islnk(3f): determine if pathname is a link" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_islnk - - INTERFACE - FUNCTION c_islnk(pathname) BIND(C, name="my_islnk") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_islnk - END INTERFACE - - IF (c_islnk(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_islnk = .TRUE. - ELSE - system_islnk = .FALSE. - END IF - -END FUNCTION system_islnk +INTERFACE + MODULE ELEMENTAL impure FUNCTION System_Islnk(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + LOGICAL :: System_Islnk + END FUNCTION System_Islnk +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1290,29 +1148,12 @@ END FUNCTION system_islnk !! !! Results: -ELEMENTAL impure FUNCTION system_isblk(pathname) - IMPLICIT NONE - -! ident_9="@(#)M_system::system_isblk(3f): determine if pathname is a block device" - - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isblk - - INTERFACE - FUNCTION c_isblk(pathname) BIND(C, name="my_isblk") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isblk - END INTERFACE - - IF (c_isblk(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isblk = .TRUE. - ELSE - system_isblk = .FALSE. - END IF - -END FUNCTION system_isblk +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Isblk(pathname) + CHARACTER(len=*), INTENT(IN) :: pathname + LOGICAL :: System_Isblk + END FUNCTION System_Isblk +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1392,27 +1233,12 @@ END FUNCTION system_isblk !! TEST is a directory !! EXAMPLE is a directory -ELEMENTAL impure FUNCTION system_isdir(dirname) - IMPLICIT NONE -! ident_10="@(#)M_system::system_isdir(3f): determine if DIRNAME is a directory name" - CHARACTER(len=*), INTENT(in) :: dirname - LOGICAL :: system_isdir - - INTERFACE - FUNCTION c_isdir(dirname) BIND(C, name="my_isdir") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: dirname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isdir - END INTERFACE - - IF (c_isdir(str2_carr(TRIM(dirname))) .EQ. 1) THEN - system_isdir = .TRUE. - ELSE - system_isdir = .FALSE. - END IF - -END FUNCTION system_isdir +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Isdir(dirname) + CHARACTER(len=*), INTENT(in) :: dirname + LOGICAL :: System_Isdir + END FUNCTION System_Isdir +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1478,32 +1304,14 @@ END FUNCTION system_isdir !! enddo !! end program demo_system_chown -ELEMENTAL impure FUNCTION system_chown(dirname, owner, group) - IMPLICIT NONE -! ident_11="@(#)M_system::system_chown(3f): change owner and group of a file relative to directory file descriptor" - CHARACTER(len=*), INTENT(in) :: dirname - INTEGER, INTENT(in) :: owner - INTEGER, INTENT(in) :: group - LOGICAL :: system_chown - -! int chown(const char *path, uid_t owner, gid_t group); - INTERFACE - function c_chown(c_dirname,c_owner,c_group) bind (C,name="my_chown") result (c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_dirname(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_owner - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_group - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_chown - END INTERFACE - - if(c_chown(str2_carr(trim(dirname)),int(owner,kind=c_int),int(group,kind=c_int)).eq.1)then - system_chown = .TRUE. - ELSE - system_chown = .FALSE. - END IF - -END FUNCTION system_chown +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Chown(dirname, owner, group) + CHARACTER(len=*), INTENT(in) :: dirname + INTEGER, INTENT(in) :: owner + INTEGER, INTENT(in) :: group + LOGICAL :: System_Chown + END FUNCTION System_Chown +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1573,22 +1381,11 @@ END FUNCTION system_chown !-! end subroutine system_cpu_time !-!end interface -SUBROUTINE system_cpu_time(total, user, system) - REAL, INTENT(out) :: user, system, total - REAL(kind=C_FLOAT) :: c_user, c_system, c_total - - INTERFACE - SUBROUTINE c_cpu_time(c_total, c_user, c_system) BIND(C, NAME='my_cpu_time') - IMPORT C_FLOAT - REAL(kind=C_FLOAT) :: c_total, c_user, c_system - END SUBROUTINE c_cpu_time - END INTERFACE - - CALL c_cpu_time(c_total, c_user, c_system) - user = c_user - system = c_system - total = c_total -END SUBROUTINE system_cpu_time +INTERFACE + MODULE SUBROUTINE system_cpu_time(total, user, system) + REAL, INTENT(OUT) :: user, system, total + END SUBROUTINE system_cpu_time +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1688,28 +1485,14 @@ END SUBROUTINE system_cpu_time !! call system_perror('*demo_system_link*') !! endif !! end program demo_system_link -ELEMENTAL impure FUNCTION system_link(oldname, newname) RESULT(ierr) - -! ident_12="@(#)M_system::system_link(3f): call link(3c) to create a file link" - - CHARACTER(len=*), INTENT(in) :: oldname - CHARACTER(len=*), INTENT(in) :: newname - INTEGER :: ierr - INTEGER(kind=C_INT) :: c_ierr - - INTERFACE - FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_link - END INTERFACE - c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) - ierr = c_ierr - -END FUNCTION system_link +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION system_link(oldname, newname) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: oldname + CHARACTER(len=*), INTENT(in) :: newname + INTEGER :: ierr + END FUNCTION system_link +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1777,22 +1560,12 @@ END FUNCTION system_link !! endif !! end program demo_system_unlink -ELEMENTAL impure FUNCTION system_unlink(fname) RESULT(ierr) - -! ident_13="@(#)M_system::system_unlink(3f): call unlink(3c) to rm file link" - - CHARACTER(len=*), INTENT(in) :: fname - INTEGER :: ierr - - INTERFACE - FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_unlink - END INTERFACE - ierr = c_unlink(str2_carr(TRIM(fname))) -END FUNCTION system_unlink +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION system_unlink(fname) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: fname + INTEGER :: ierr + END FUNCTION system_unlink +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1859,14 +1632,13 @@ END FUNCTION system_unlink !! 18 O'022' Z"12' B'000010010" !! NEW !! 63 O'077' Z"3F' B'000111111" -INTEGER FUNCTION system_setumask(umask_value) RESULT(old_umask) - INTEGER, INTENT(in) :: umask_value - INTEGER(kind=C_INT) :: umask_c - umask_c = umask_value - old_umask = system_umask(umask_c) ! set current umask - -END FUNCTION system_setumask +INTERFACE + MODULE FUNCTION system_setumask(umask_value) RESULT(old_umask) + INTEGER, INTENT(in) :: umask_value + INTEGER :: old_umask + END FUNCTION system_setumask +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1895,7 +1667,8 @@ END FUNCTION system_setumask !! Expected output !! !! 18 O'022' Z"12' B'000010010" -INTEGER FUNCTION system_getumask() RESULT(umask_value) +INTERFACE + MODULE FUNCTION system_getumask() RESULT(umask_value) ! The return value from umask() is just the previous value of the file ! creation mask, so that this system call can be used both to get and ! set the required values. Sadly, however, there is no way to get the old @@ -1903,12 +1676,9 @@ INTEGER FUNCTION system_getumask() RESULT(umask_value) ! This means that in order just to see the current value, it is necessary ! to execute a piece of code like the following function: - INTEGER :: idum - INTEGER(kind=C_INT) :: old_umask - old_umask = system_umask(0_C_INT) ! get current umask but by setting umask to 0 (a conservative mask so no vulnerability is open) - idum = system_umask(old_umask) ! set back to original mask - umask_value = old_umask -END FUNCTION system_getumask + INTEGER :: umask_value + END FUNCTION system_getumask +END INTERFACE !---------------------------------------------------------------------------- ! @@ -1953,28 +1723,11 @@ END FUNCTION system_getumask !! *demo_system_perror*:/NOT/THERE/OR/ANYWHERE: No such file or directory !! That is all Folks! -SUBROUTINE system_perror(prefix) - USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT ! access computing environment - -! ident_14="@(#)M_system::system_perror(3f): call perror(3c) to display error message" - - CHARACTER(len=*), INTENT(in) :: prefix - INTEGER :: ios - - INTERFACE - SUBROUTINE c_perror(c_prefix) BIND(C, name="perror") - IMPORT C_CHAR - CHARACTER(kind=C_CHAR) :: c_prefix(*) - END SUBROUTINE c_perror - END INTERFACE - - FLUSH (unit=ERROR_UNIT, iostat=ios) - FLUSH (unit=OUTPUT_UNIT, iostat=ios) - FLUSH (unit=INPUT_UNIT, iostat=ios) - CALL c_perror(str2_carr((TRIM(prefix)))) - CALL c_flush() - -END SUBROUTINE system_perror +INTERFACE + MODULE SUBROUTINE system_perror(prefix) + CHARACTER(len=*), INTENT(in) :: prefix + END SUBROUTINE system_perror +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2045,24 +1798,12 @@ END SUBROUTINE system_perror !! /tmp !! *CHDIR TEST* IERR= 0 -SUBROUTINE system_chdir(path, err) -! ident_15="@(#)M_system::system_chdir(3f): call chdir(3c)" - CHARACTER(len=*) :: path - INTEGER, OPTIONAL, INTENT(out) :: err - - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_chdir(c_path) BIND(C, name="chdir") - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR) :: c_path(*) - END FUNCTION - END INTERFACE - INTEGER :: loc_err -!----------------------------------------------------------------------------------------------------------------------------------- - loc_err = c_chdir(str2_carr(TRIM(path))) - IF (PRESENT(err)) THEN - err = loc_err - END IF -END SUBROUTINE system_chdir +INTERFACE + MODULE SUBROUTINE system_chdir(path, err) + CHARACTER(len=*) :: path + INTEGER, OPTIONAL, INTENT(out) :: err + END SUBROUTINE system_chdir +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2135,21 +1876,12 @@ END SUBROUTINE system_chdir !!##LICENSE !! Public Domain -ELEMENTAL impure FUNCTION system_remove(path) RESULT(err) -! ident_16="@(#)M_system::system_remove(3f): call remove(3c) to remove file" - CHARACTER(*), INTENT(in) :: path - INTEGER(C_INT) :: err - - INTERFACE - FUNCTION c_remove(c_path) BIND(c, name="remove") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - err = c_remove(str2_carr(TRIM(path))) -END FUNCTION system_remove +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION system_remove(path) RESULT(err) + CHARACTER(*), INTENT(in) :: path + INTEGER(C_INT) :: err + END FUNCTION system_remove +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2241,23 +1973,13 @@ END FUNCTION system_remove !! John S. Urban !!##LICENSE !! Public Domain -FUNCTION system_rename(input, output) RESULT(ierr) - -! ident_17="@(#)M_system::system_rename(3f): call rename(3c) to change filename" - - CHARACTER(*), INTENT(in) :: input, output - INTEGER :: ierr - INTERFACE - FUNCTION c_rename(c_input, c_output) BIND(c, name="rename") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) - CHARACTER(kind=C_CHAR), INTENT(in) :: c_output(*) - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - ierr = c_rename(str2_carr(TRIM(input)), str2_carr(TRIM(output))) -END FUNCTION system_rename + +INTERFACE + MODULE FUNCTION system_rename(input, output) RESULT(ierr) + CHARACTER(*), INTENT(in) :: input, output + INTEGER :: ierr + END FUNCTION system_rename +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2370,21 +2092,13 @@ END FUNCTION system_rename !!##LICENSE !! Public Domain -FUNCTION system_chmod(filename, mode) RESULT(ierr) - CHARACTER(len=*), INTENT(in) :: filename - INTEGER, VALUE, INTENT(in) :: mode - INTEGER :: ierr - INTERFACE - FUNCTION c_chmod(c_filename, c_mode) BIND(c, name="chmod") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_filename(*) - INTEGER(C_INT), VALUE, INTENT(in) :: c_mode - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - ierr = c_chmod(str2_carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) -END FUNCTION system_chmod +INTERFACE + MODULE FUNCTION system_chmod(filename, mode) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: filename + INTEGER, VALUE, INTENT(in) :: mode + INTEGER :: ierr + END FUNCTION system_chmod +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2431,32 +2145,12 @@ END FUNCTION system_chmod !!##LICENSE !! Public Domain -SUBROUTINE system_getcwd(output, ierr) -! ident_18="@(#)M_system::system_getcwd(3f):call getcwd(3c) to get pathname of current working directory" - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output - INTEGER, INTENT(out) :: ierr - INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG - CHARACTER(kind=C_CHAR, len=1) :: buffer(length) - TYPE(C_PTR) :: buffer2 - INTERFACE - FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) - IMPORT C_CHAR, C_SIZE_T, C_PTR - CHARACTER(kind=C_CHAR), INTENT(out) :: buffer(*) - INTEGER(C_SIZE_T), VALUE, INTENT(in) :: size - TYPE(C_PTR) :: buffer_result - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - buffer = ' ' - buffer2 = c_getcwd(buffer, length) - IF (.NOT. C_ASSOCIATED(buffer2)) THEN - output = '' - ierr = -1 - ELSE - output = TRIM(arr2str(buffer)) - ierr = 0 - END IF -END SUBROUTINE system_getcwd +INTERFACE + MODULE SUBROUTINE system_getcwd(output, ierr) + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output + INTEGER, INTENT(out) :: ierr + END SUBROUTINE system_getcwd +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2515,26 +2209,16 @@ END SUBROUTINE system_getcwd !! John S. Urban !!##LICENSE !! Public Domain -FUNCTION system_rmdir(dirname) RESULT(err) - -! ident_19="@(#)M_system::system_rmdir(3f): call rmdir(3c) to remove empty directory" - - CHARACTER(*), INTENT(in) :: dirname - INTEGER(C_INT) :: err - - INTERFACE - FUNCTION c_rmdir(c_path) BIND(c, name="rmdir") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) - INTEGER(C_INT) :: c_err - END FUNCTION - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - err = c_rmdir(str2_carr(TRIM(dirname))) - IF (err .NE. 0) err = system_errno() -END FUNCTION system_rmdir + +INTERFACE + MODULE FUNCTION system_rmdir(dirname) RESULT(err) + CHARACTER(*), INTENT(in) :: dirname + INTEGER(C_INT) :: err + END FUNCTION system_rmdir +END INTERFACE + !---------------------------------------------------------------------------- -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +! !---------------------------------------------------------------------------- !> !!##NAME @@ -2652,29 +2336,17 @@ END FUNCTION system_rmdir !! John S. Urban !!##LICENSE !! Public Domain -FUNCTION system_mkfifo(pathname, mode) RESULT(err) - -! ident_20="@(#)M_system::system_mkfifo(3f): call mkfifo(3c) to create a new FIFO special file" - - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in) :: mode - INTEGER :: c_mode - INTEGER :: err - - INTERFACE - FUNCTION c_mkfifo(c_path, c_mode) BIND(c, name="mkfifo") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) - INTEGER(C_INT), INTENT(in), VALUE :: c_mode - INTEGER(C_INT) :: c_err - END FUNCTION c_mkfifo - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - c_mode = mode - err = c_mkfifo(str2_carr(TRIM(pathname)), c_mode) -END FUNCTION system_mkfifo + +INTERFACE + MODULE FUNCTION system_mkfifo(pathname, mode) RESULT(err) + CHARACTER(len=*), INTENT(in) :: pathname + INTEGER, INTENT(in) :: mode + INTEGER :: err + END FUNCTION system_mkfifo +END INTERFACE + !---------------------------------------------------------------------------- -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +! !---------------------------------------------------------------------------- !> !!##NAME @@ -2731,45 +2403,14 @@ END FUNCTION system_mkfifo !! John S. Urban !!##LICENSE !! Public Domain -FUNCTION system_mkdir(dirname, mode) RESULT(ierr) - -! ident_21="@(#)M_system::system_mkdir(3f): call mkdir(3c) to create empty directory" - - CHARACTER(len=*), INTENT(in) :: dirname - INTEGER, INTENT(in) :: mode - INTEGER :: c_mode - INTEGER(kind=C_INT) :: err - INTEGER :: ierr - - INTERFACE - FUNCTION c_mkdir(c_path, c_mode) BIND(c, name="mkdir") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) - INTEGER(C_INT), INTENT(in), VALUE :: c_mode - INTEGER(C_INT) :: c_err - END FUNCTION c_mkdir - END INTERFACE - INTERFACE - SUBROUTINE my_mkdir(string, c_mode, c_err) BIND(C, name="my_mkdir") - USE ISO_C_BINDING, ONLY: C_CHAR, C_INT - CHARACTER(kind=C_CHAR) :: string(*) - INTEGER(C_INT), INTENT(in), VALUE :: c_mode - INTEGER(C_INT) :: c_err - END SUBROUTINE my_mkdir - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - c_mode = mode - IF (INDEX(dirname, '/') .NE. 0) THEN - CALL my_mkdir(str2_carr(TRIM(dirname)), c_mode, err) - ELSE - err = c_mkdir(str2_carr(TRIM(dirname)), c_mode) - END IF - ierr = err ! c_int to default integer kind -END FUNCTION system_mkdir -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- +INTERFACE + MODULE FUNCTION system_mkdir(dirname, mode) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: dirname + INTEGER, INTENT(in) :: mode + INTEGER :: ierr + END FUNCTION system_mkdir +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2863,27 +2504,13 @@ END FUNCTION system_mkdir !!##LICENSE !! Public Domain -SUBROUTINE system_opendir(dirname, dir, ierr) - CHARACTER(len=*), INTENT(in) :: dirname - TYPE(C_PTR) :: dir - INTEGER, INTENT(out) :: ierr - - INTERFACE - FUNCTION c_opendir(c_dirname) BIND(c, name="opendir") RESULT(c_dir) - IMPORT C_CHAR, C_INT, C_PTR - CHARACTER(kind=C_CHAR), INTENT(in) :: c_dirname(*) - TYPE(C_PTR) :: c_dir - END FUNCTION c_opendir - END INTERFACE - - ierr = 0 - dir = c_opendir(str2_carr(TRIM(dirname))) - IF (.NOT. C_ASSOCIATED(dir)) THEN - WRITE (*, '(a)') '*system_opendir* Error opening '//TRIM(dirname) - ierr = -1 - END IF - -END SUBROUTINE system_opendir +INTERFACE + MODULE SUBROUTINE system_opendir(dirname, dir, ierr) + CHARACTER(len=*), INTENT(in) :: dirname + TYPE(C_PTR) :: dir + INTEGER, INTENT(out) :: ierr + END SUBROUTINE system_opendir +END INTERFACE !---------------------------------------------------------------------------- ! @@ -2965,32 +2592,16 @@ END SUBROUTINE system_opendir !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_readdir(dir, filename, ierr) - TYPE(C_PTR), VALUE :: dir - CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename - INTEGER, INTENT(out) :: ierr - INTEGER(kind=C_INT) :: ierr_local - - CHARACTER(kind=C_CHAR, len=1) :: buf(4097) - - INTERFACE - SUBROUTINE c_readdir(c_dir, c_filename, c_ierr) BIND(C, NAME='my_readdir') - IMPORT C_CHAR, C_INT, C_PTR - TYPE(C_PTR), VALUE :: c_dir - CHARACTER(kind=C_CHAR) :: c_filename(*) - INTEGER(kind=C_INT) :: c_ierr - END SUBROUTINE c_readdir - END INTERFACE - - buf = ' ' - ierr_local = 0 - CALL c_readdir(dir, buf, ierr_local) - filename = TRIM(arr2str(buf)) - ierr = ierr_local - -END SUBROUTINE system_readdir -!---------------------------------------------------------------------------- +INTERFACE + MODULE SUBROUTINE system_readdir(dir, filename, ierr) + TYPE(C_PTR), VALUE :: dir + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename + INTEGER, INTENT(out) :: ierr + END SUBROUTINE system_readdir +END INTERFACE + +!---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- !> @@ -3043,19 +2654,12 @@ END SUBROUTINE system_readdir !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_rewinddir(dir) - TYPE(C_PTR), VALUE :: dir - - INTERFACE - SUBROUTINE c_rewinddir(c_dir) BIND(c, name="rewinddir") - IMPORT C_CHAR, C_INT, C_PTR - TYPE(C_PTR), VALUE :: c_dir - END SUBROUTINE c_rewinddir - END INTERFACE - - CALL c_rewinddir(dir) -END SUBROUTINE system_rewinddir +INTERFACE + MODULE SUBROUTINE system_rewinddir(dir) + TYPE(C_PTR), VALUE :: dir + END SUBROUTINE system_rewinddir +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3110,31 +2714,13 @@ END SUBROUTINE system_rewinddir !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_closedir(dir, ierr) - USE ISO_C_BINDING - TYPE(C_PTR), VALUE :: dir - INTEGER, INTENT(out), OPTIONAL :: ierr - INTEGER :: ierr_local - - INTERFACE - FUNCTION c_closedir(c_dir) BIND(c, name="closedir") RESULT(c_err) - IMPORT C_CHAR, C_INT, C_PTR - TYPE(C_PTR), VALUE :: c_dir - INTEGER(kind=C_INT) :: c_err - END FUNCTION c_closedir - END INTERFACE - - ierr_local = c_closedir(dir) - IF (PRESENT(ierr)) THEN - ierr = ierr_local - ELSE - IF (ierr_local /= 0) THEN - PRINT *, "*system_closedir* error", ierr_local - STOP 3 - END IF - END IF - -END SUBROUTINE system_closedir + +INTERFACE + MODULE SUBROUTINE system_closedir(dir, ierr) + TYPE(C_PTR), VALUE :: dir + INTEGER, INTENT(out), OPTIONAL :: ierr + END SUBROUTINE system_closedir +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3209,35 +2795,24 @@ END SUBROUTINE system_closedir !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_putenv(string, err) -! ident_22="@(#)M_system::system_putenv(3f): call putenv(3c)" - - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_string(*) - END FUNCTION - END INTERFACE - - CHARACTER(len=*), INTENT(in) :: string - INTEGER, OPTIONAL, INTENT(out) :: err - INTEGER :: loc_err - INTEGER :: i - - ! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit - CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) - - ALLOCATE (memleak(LEN(string) + 1)) - DO i = 1, LEN(string) - memleak(i) = string(i:i) - END DO - memleak(LEN(string) + 1) = C_NULL_CHAR +INTERFACE + MODULE SUBROUTINE system_putenv(string, err) + CHARACTER(len=*), INTENT(in) :: string + INTEGER, OPTIONAL, INTENT(out) :: err + END SUBROUTINE system_putenv +END INTERFACE - loc_err = c_putenv(memleak) - IF (PRESENT(err)) err = loc_err +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -END SUBROUTINE system_putenv +INTERFACE + MODULE PURE FUNCTION arr2str(array) RESULT(string) + CHARACTER(len=1), INTENT(in) :: array(:) + CHARACTER(len=SIZE(array)) :: string + END FUNCTION arr2str +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3281,39 +2856,16 @@ END SUBROUTINE system_putenv !! John S. Urban !!##LICENSE !! Public Domain -FUNCTION system_getenv(name, default) RESULT(VALUE) - -! ident_23="@(#)M_system::system_getenv(3f): call get_environment_variable as a function with a default value(3f)" - - CHARACTER(len=*), INTENT(in) :: name - CHARACTER(len=*), INTENT(in), OPTIONAL :: default - INTEGER :: howbig - INTEGER :: stat - CHARACTER(len=:), ALLOCATABLE :: VALUE - - IF (NAME .NE. '') THEN - call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value - IF (howbig .NE. 0) THEN - SELECT CASE (stat) - CASE (1) ! print *, NAME, " is not defined in the environment. Strange..." - VALUE = '' - CASE (2) ! print *, "This processor doesn't support environment variables. Boooh!" - VALUE = '' - CASE default ! make string to hold value of sufficient size and get value - IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) - ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) - CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) - IF (stat .NE. 0) VALUE = '' - END SELECT - ELSE - VALUE = '' - END IF - ELSE - VALUE = '' - END IF - IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default - -END FUNCTION system_getenv + +INTERFACE + MODULE FUNCTION system_getenv(name, default) RESULT(VALUE) + CHARACTER(len=*), INTENT(in) :: name + CHARACTER(len=*), INTENT(in), OPTIONAL :: default + INTEGER :: howbig + INTEGER :: stat + CHARACTER(len=:), ALLOCATABLE :: VALUE + END FUNCTION system_getenv +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3377,26 +2929,14 @@ END FUNCTION system_getenv !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE set_environment_variable(NAME, VALUE, STATUS) - -! ident_24="@(#)M_system::set_environment_variable(3f): call setenv(3c) to set environment variable" - - CHARACTER(len=*) :: NAME - CHARACTER(len=*) :: VALUE - INTEGER, OPTIONAL, INTENT(out) :: STATUS - INTEGER :: loc_err - - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_name(*) - CHARACTER(kind=C_CHAR) :: c_VALUE(*) - END FUNCTION - END INTERFACE - loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) - IF (PRESENT(STATUS)) STATUS = loc_err -END SUBROUTINE set_environment_variable +INTERFACE + MODULE SUBROUTINE set_environment_variable(NAME, VALUE, STATUS) + CHARACTER(len=*) :: NAME + CHARACTER(len=*) :: VALUE + INTEGER, OPTIONAL, INTENT(out) :: STATUS + END SUBROUTINE set_environment_variable +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3447,53 +2987,12 @@ END SUBROUTINE set_environment_variable !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_clearenv(ierr) -! emulating because not available on some platforms - -! ident_25="@(#)M_system::system_clearenv(3f): emulate clearenv(3c) to clear environment" - - INTEGER, INTENT(out), OPTIONAL :: ierr - CHARACTER(len=:), ALLOCATABLE :: string - INTEGER :: ierr_local1, ierr_local2 - ierr_local2 = 0 - INFINITE: DO - CALL system_initenv() ! important -- changing table causes undefined behavior so reset after each unsetenv - string = system_readenv() ! get first name=value pair - IF (string .EQ. '') EXIT INFINITE - CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair - IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 - END DO INFINITE - IF (PRESENT(ierr)) THEN - ierr = ierr_local2 - ELSEIF (ierr_local2 .NE. 0) THEN ! if error occurs and not being returned, stop - WRITE (*, *) '*system_clearenv* error=', ierr_local2 - STOP - END IF -END SUBROUTINE system_clearenv -!--subroutine system_clearenv(ierr) -!--! clearenv(3c) not available on some systems I tried -!--! Found reference that if it is unavailable the assignment -! "environ = NULL;" will probably do but emulating instead -!--$@ (#)M_system::system_clearenv(3f): call clearenv(3c) to clear -! "environment" -!--integer,intent(out),optional :: ierr -!-- integer :: ierr_local -!-- -!--interface -!-- integer(kind=c_int) function c_clearenv() bind(C,NAME="clearenv") -!-- import c_int -!-- end function -!--end interface -!-- -!-- ierr_local = c_clearenv() -!-- if(present(ierr))then -!-- ierr=ierr_local -!-- elseif(ierr_local.ne.0)then ! if error occurs and not being returned, stop -!-- write(*,*)'*system_clearenv* error=',ierr_local -!-- stop -!-- endif -!-- -!--end subroutine system_clearenv + +INTERFACE + MODULE SUBROUTINE system_clearenv(ierr) + INTEGER, INTENT(out), OPTIONAL :: ierr + END SUBROUTINE system_clearenv +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3543,32 +3042,13 @@ END SUBROUTINE system_clearenv !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_unsetenv(name, ierr) -! ident_26="@(#)M_system::system_unsetenv(3f): call unsetenv(3c) to remove variable from environment" - - CHARACTER(len=*), INTENT(in) :: name - INTEGER, INTENT(out), OPTIONAL :: ierr - INTEGER :: ierr_local - -! int unsetenv(void) - INTERFACE - INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") - IMPORT C_INT, C_CHAR - CHARACTER(len=1, kind=C_CHAR) :: c_name(*) - END FUNCTION - END INTERFACE - - ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) - - IF (PRESENT(ierr)) THEN - ierr = ierr_local - ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop - WRITE (*, *) '*system_unsetenv* error=', ierr_local - STOP - END IF - -END SUBROUTINE system_unsetenv +INTERFACE + MODULE SUBROUTINE system_unsetenv(name, ierr) + CHARACTER(len=*), INTENT(in) :: name + INTEGER, INTENT(out), OPTIONAL :: ierr + END SUBROUTINE system_unsetenv +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3629,29 +3109,14 @@ END SUBROUTINE system_unsetenv !!##LICENSE !! Public Domain -FUNCTION system_readenv() RESULT(string) - -! ident_27="@(#)M_system::system_readenv(3f): read next entry from environment table" - - CHARACTER(len=:), ALLOCATABLE :: string - CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) - - INTERFACE - SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') - IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T - CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) - END SUBROUTINE c_readenv - END INTERFACE - - c_buff = ' ' - c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR - CALL c_readenv(c_buff) - string = TRIM(arr2str(c_buff)) - -END FUNCTION system_readenv +INTERFACE + MODULE FUNCTION system_readenv() RESULT(string) + CHARACTER(len=:), ALLOCATABLE :: string + END FUNCTION system_readenv +END INTERFACE !---------------------------------------------------------------------------- -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +! !---------------------------------------------------------------------------- !> !!##NAME @@ -3698,41 +3163,18 @@ END FUNCTION system_readenv !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE fileglob(glob, list) ! NON-PORTABLE AT THIS POINT. REQUIRES ls(1) command, assumes 1 line per file -! The length of the character strings in list() must be long enough for the filenames. -! The list can be zero names long, it is still allocated. - IMPLICIT NONE - -! ident_28="@(#)M_system::fileglob(3f): Returns list of files using a file globbing pattern" - -!----------------------------------------------------------------------------------------------------------------------------------- - CHARACTER(len=*), INTENT(in) :: glob ! Pattern for the filenames (like: *.txt) - CHARACTER(len=*), POINTER :: list(:) ! Allocated list of filenames (returned), the caller must deallocate it. -!----------------------------------------------------------------------------------------------------------------------------------- - CHARACTER(len=255) :: tmpfile ! scratch filename to hold expanded file list - CHARACTER(len=255) :: cmd ! string to build system command in - INTEGER :: iotmp ! needed to open unique scratch file for holding file list - INTEGER :: i, ios, icount - write(tmpfile,'(*(g0))')'/tmp/__filelist_',timestamp(),'_',system_getpid() ! preliminary scratch file name - cmd = 'ls -d '//TRIM(glob)//'>'//TRIM(tmpfile)//' ' ! build command string - CALL execute_command_line(cmd) ! Execute the command specified by the string. - OPEN (newunit=iotmp, file=tmpfile, iostat=ios) ! open unique scratch filename - IF (ios .NE. 0) RETURN ! the open failed - icount = 0 ! number of filenames in expanded list - DO ! count the number of lines (assumed ==files) so know what to allocate - READ (iotmp, '(a)', iostat=ios) ! move down a line in the file to count number of lines - IF (ios .NE. 0) EXIT ! hopefully, this is because end of file was encountered so done - icount = icount + 1 ! increment line count - END DO - REWIND (iotmp) ! rewind file list so can read and store it - ALLOCATE (list(icount)) ! allocate and fill the array - DO i = 1, icount - READ (iotmp, '(a)') list(i) ! read a filename from a line - END DO - CLOSE (iotmp, status='delete', iostat=ios) ! close and delete scratch file -END SUBROUTINE fileglob + +INTERFACE + MODULE SUBROUTINE fileglob(glob, list) + CHARACTER(len=*), INTENT(in) :: glob + !! Pattern for the filenames (like: *.txt) + CHARACTER(len=*), POINTER :: list(:) + !! Allocated list of filenames (returned), the caller must deallocate it. + END SUBROUTINE fileglob +END INTERFACE + !---------------------------------------------------------------------------- -!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +! !---------------------------------------------------------------------------- !> !!##NAME @@ -3778,30 +3220,13 @@ END SUBROUTINE fileglob !! John S. Urban !!##LICENSE !! Public Domain -SUBROUTINE system_uname(WHICH, NAMEOUT) - IMPLICIT NONE - -! ident_29="@(#)M_system::system_uname(3f): call my_uname(3c) which calls uname(3c)" - CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH - CHARACTER(len=*), INTENT(out) :: NAMEOUT - -! describe the C routine to Fortran -! void system_uname(char *which, char *buf, int *buflen); - INTERFACE - SUBROUTINE system_uname_c(WHICH, BUF, BUFLEN) BIND(C, NAME='my_uname') - IMPORT C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH - CHARACTER(KIND=C_CHAR), INTENT(out) :: BUF(*) - INTEGER(kind=C_INT), INTENT(in) :: BUFLEN - END SUBROUTINE system_uname_c - END INTERFACE - - NAMEOUT = 'unknown' - CALL system_uname_c(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) - -END SUBROUTINE system_uname +INTERFACE + MODULE SUBROUTINE system_uname(WHICH, NAMEOUT) + CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH + CHARACTER(len=*), INTENT(out) :: NAMEOUT + END SUBROUTINE system_uname +END INTERFACE !---------------------------------------------------------------------------- ! @@ -3847,893 +3272,277 @@ END SUBROUTINE system_uname !!##LICENSE !! Public Domain -SUBROUTINE system_gethostname(NAME, IERR) - IMPLICIT NONE - -! ident_30="@(#)M_system::system_gethostname(3f): get name of current host by calling gethostname(3c)" - - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: NAME - INTEGER, INTENT(out) :: IERR - CHARACTER(kind=C_CHAR, len=1) :: C_BUFF(HOST_NAME_MAX + 1) - -! describe the C routine to Fortran -!int gethostname(char *name, size_t namelen); - INTERFACE - FUNCTION system_gethostname_c(c_buf, c_buflen) BIND(C, NAME='gethostname') - IMPORT C_CHAR, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: system_gethostname_c - CHARACTER(KIND=C_CHAR), INTENT(out) :: c_buf(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_buflen - END FUNCTION system_gethostname_c - END INTERFACE - - C_BUFF = ' ' - ierr = system_gethostname_c(C_BUFF, HOST_NAME_MAX) ! Host names are limited to {HOST_NAME_MAX} bytes. - NAME = TRIM(arr2str(C_BUFF)) - -END SUBROUTINE system_gethostname +INTERFACE + MODULE SUBROUTINE system_gethostname(NAME, IERR) + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: NAME + INTEGER, INTENT(out) :: IERR + END SUBROUTINE system_gethostname +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getlogin@GetMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_getlogin(3f) - [M_system:QUERY] get login name -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_getlogin() result (fname) -!! -!! character(len=:),allocatable :: FNAME -!! -!!##DESCRIPTION -!! -!! The system_getlogin(3f) function returns a string containing the user -!! name associated by the login activity with the controlling terminal -!! of the current process. Otherwise, it returns a null string and sets -!! errno to indicate the error. -!! -!! Three names associated with the current process can be determined: -!! -!! o system_getpwuid(system_getuid()) returns the name associated with the real user ID of the process. -!! o system_getpwuid(system_geteuid()) returns the name associated with the effective user ID of the process -!! o system_getlogin() returns the name associated with the current login activity -!! -!!##RETURN VALUE -!! fname returns the login name. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getlogin -!! use M_system, only : system_getlogin -!! implicit none -!! character(len=:),allocatable :: name -!! name=system_getlogin() -!! write(*,'("login[",a,"]")')name -!! end program demo_system_getlogin -!! -!! Results: -!! -!! login[JSU] -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -!-- The following example calls the getlogin() function to obtain the name of the user associated with the calling process, -!-- and passes this information to the getpwnam() function to get the associated user database information. -!-- ... -!-- char *lgn; -!-- struct passwd *pw; -!-- ... -!-- if ((lgn = getlogin()) == NULL || (pw = getpwnam(lgn)) == NULL) { -!-- fprintf(stderr, "Get of user information failed.\n"); exit(1); -!-- } -!--APPLICATION USAGE -!--SEE ALSO -!-- getpwnam(), getpwuid(), system_geteuid(), getuid() -FUNCTION system_getlogin() RESULT(fname) - CHARACTER(len=:), ALLOCATABLE :: fname - TYPE(C_PTR) :: username - - INTERFACE - FUNCTION c_getlogin() BIND(c, name="getlogin") RESULT(c_username) - IMPORT C_INT, C_PTR - TYPE(C_PTR) :: c_username - END FUNCTION c_getlogin - END INTERFACE - - username = c_getlogin() - IF (.NOT. C_ASSOCIATED(username)) THEN - !! in windows 10 subsystem running Ubunto does not work - !!write(*,'(a)')'*system_getlogin* Error getting username. not associated' - !!fname=c_null_char - fname = system_getpwuid(system_geteuid()) - ELSE - fname = c2f_string(username) - END IF - -END FUNCTION system_getlogin - -!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get login name ! -!---------------------------------------------------------------------------- +! ## System_Getlogin +! +! The `system_getlogin(3f)` function returns a string containing the user +! name associated with the login activity of the controlling terminal of the +! current process. +! +! If the user name cannot be determined, the function returns a null string +! and sets `errno` to indicate the error. +! +! The following three user names associated with the current process can be +! determined: +! +! - `system_getpwuid(system_getuid())` +! Returns the name associated with the real user ID of the process. +! +! - `system_getpwuid(system_geteuid())` +! Returns the name associated with the effective user ID of the process. +! +! - `system_getlogin()` +! Returns the name associated with the current login activity.!! -!> -!!##NAME -!! system_perm(3f) - [M_system:QUERY_FILE] get file type and permission as a string -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_perm(mode) result (perms) -!! -!! integer(kind=int64),intent(in) :: MODE -!! character(len=:),allocatable :: PERMS -!! -!!##DESCRIPTION -!! -!! The system_perm(3f) function returns a string containing the type -!! and permission of a file implied by the value of the mode value. -!! -!!##RETURN VALUE -!! PERMS returns the permission string in a format similar to that -!! used by Unix commands such as ls(1). -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_perm -!! use M_system, only : system_perm, system_stat -!! use,intrinsic :: iso_fortran_env, only : int64 -!! implicit none -!! character(len=4096) :: string -!! integer(kind=int64) :: values(13) -!! integer :: ierr -!! character(len=:),allocatable :: perms -!! values=0 -!! ! get pathname from command line -!! call get_command_argument(1, string) -!! ! get pathname information -!! call system_stat(string,values,ierr) -!! if(ierr.eq.0)then -!! ! convert permit mode to a string -!! perms=system_perm(values(3)) -!! ! print permits as a string, decimal value, and octal value -!! write(*,'("for ",a," permits[",a,"]",1x,i0,1x,o0)') & -!! & trim(string),perms,values(3),values(3) -!! endif -!! end program demo_system_perm -!! -!! Results: -!! -!! demo_system_perm /tmp -!! -!! for /tmp permits[drwxrwxrwx --S] 17407 41777 -!! -!!##AUTHOR -!! John S. Urban -!! -!!##LICENSE -!! Public Domain -FUNCTION system_perm(mode) RESULT(perms) - CLASS(*), INTENT(in) :: mode - CHARACTER(len=:), ALLOCATABLE :: perms - TYPE(C_PTR) :: permissions - INTEGER(kind=C_LONG) :: mode_local - INTERFACE - FUNCTION c_perm(c_mode) BIND(c, name="my_get_perm") RESULT(c_permissions) - IMPORT C_INT, C_PTR, C_LONG - INTEGER(kind=C_LONG), VALUE :: c_mode - TYPE(C_PTR) :: c_permissions - END FUNCTION c_perm - END INTERFACE - - mode_local = INT(anyinteger_to_64bit(mode), kind=C_LONG) - permissions = c_perm(mode_local) - IF (.NOT. C_ASSOCIATED(permissions)) THEN - WRITE (*, '(a)') '*system_perm* Error getting permissions. not associated' - perms = C_NULL_CHAR - ELSE - perms = c2f_string(permissions) - END IF - -END FUNCTION system_perm +INTERFACE + MODULE FUNCTION System_Getlogin() RESULT(fname) + CHARACTER(:), ALLOCATABLE :: fname + END FUNCTION System_Getlogin +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Perm@GetMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_getgrgid(3f) - [M_system:QUERY] get groupd name associated with a GID -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_getgrgid(gid) result (gname) -!! -!! class(*),intent(in) :: gid ! any INTEGER type -!! character(len=:),allocatable :: gname -!! -!!##DESCRIPTION -!! -!! The system_getlogin() function returns a string containing the group -!! name associated with the given GID. If no match is found -!! it returns a null string and sets errno to indicate the error. -!! -!!##OPTION -!! gid GID to try to look up associated group for. Can be of any -!! INTEGER type. -!! -!!##RETURN VALUE -!! gname returns the group name. Blank if an error occurs -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getgrgid -!! use M_system, only : system_getgrgid -!! use M_system, only : system_getgid -!! implicit none -!! character(len=:),allocatable :: name -!! name=system_getgrgid( system_getgid() ) -!! write(*,'("group[",a,"] for ",i0)')name,system_getgid() -!! end program demo_system_getgrgid -!! -!! Results: -!! -!! group[default] for 197121 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_getgrgid(gid) RESULT(gname) - CLASS(*), INTENT(in) :: gid - CHARACTER(len=:), ALLOCATABLE :: gname - CHARACTER(kind=C_CHAR, len=1) :: groupname(4097) ! assumed long enough for any groupname - INTEGER :: ierr - INTEGER(kind=C_LONG_LONG) :: gid_local - - INTERFACE - function c_getgrgid(c_gid,c_groupname) bind(c,name="my_getgrgid") result(c_ierr) - IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG - INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_gid - CHARACTER(kind=C_CHAR), INTENT(out) :: c_groupname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_getgrgid - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - gid_local = anyinteger_to_64bit(gid) - ierr = c_getgrgid(gid_local, groupname) - IF (ierr .EQ. 0) THEN - gname = TRIM(arr2str(groupname)) - ELSE - gname = '' - END IF -!----------------------------------------------------------------------------------------------------------------------------------- -END FUNCTION system_getgrgid - -!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get file type and permission as a string ! -!---------------------------------------------------------------------------- +!# System_Perm +! +! The system_perm(3f) function returns a string containing the type +! and permission of a file implied by the value of the mode value. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Perm_test_1.F90" %}} +!``` -!> -!!##NAME -!! system_getpwuid(3f) - [M_system:QUERY] get login name associated with a UID -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_getpwuid(uid) result (uname) -!! -!! class(*),intent(in) :: uid ! any INTEGER type -!! character(len=:),allocatable :: uname -!! -!!##DESCRIPTION -!! -!! The system_getpwuid() function returns a string containing the user -!! name associated with the given UID. If no match is found it returns -!! a null string and sets errno to indicate the error. -!! -!!##OPTION -!! uid UID to try to look up associated username for. Can be of any -!! INTEGER type. -!! -!!##RETURN VALUE -!! uname returns the login name. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getpwuid -!! use M_system, only : system_getpwuid -!! use M_system, only : system_getuid -!! use,intrinsic :: iso_fortran_env, only : int64 -!! implicit none -!! character(len=:),allocatable :: name -!! integer(kind=int64) :: uid -!! uid=system_getuid() -!! name=system_getpwuid(uid) -!! write(*,'("login[",a,"] has UID ",i0)')name,uid -!! end program demo_system_getpwuid -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain -FUNCTION system_getpwuid(uid) RESULT(uname) - CLASS(*), INTENT(in) :: uid - CHARACTER(len=:), ALLOCATABLE :: uname - CHARACTER(kind=C_CHAR, len=1) :: username(4097) ! assumed long enough for any username - INTEGER :: ierr - INTEGER(kind=C_LONG_LONG) :: uid_local - - INTERFACE - function c_getpwuid(c_uid,c_username) bind(c,name="my_getpwuid") result(c_ierr) - IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG - INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_uid - CHARACTER(kind=C_CHAR), INTENT(out) :: c_username(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_getpwuid - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - uid_local = anyinteger_to_64bit(uid) - ierr = c_getpwuid(uid_local, username) - IF (ierr .EQ. 0) THEN - uname = TRIM(arr2str(username)) - ELSE - uname = '' - END IF -!----------------------------------------------------------------------------------------------------------------------------------- -END FUNCTION system_getpwuid +INTERFACE + MODULE FUNCTION System_Perm(mode) RESULT(perms) + CLASS(*), INTENT(IN) :: mode + CHARACTER(len=:), ALLOCATABLE :: perms + !! returns the permission string in a format similar to that + !! used by Unix commands such as ls(1). + END FUNCTION System_Perm +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getgrgid@GetMethods !---------------------------------------------------------------------------- -PURE FUNCTION arr2str(array) RESULT(string) - -! ident_31="@(#)M_system::arr2str(3fp): function copies null-terminated char array to string" - - CHARACTER(len=1), INTENT(in) :: array(:) - CHARACTER(len=SIZE(array)) :: string - INTEGER :: i - - string = ' ' - DO i = 1, SIZE(array) - IF (array(i) .EQ. CHAR(0)) THEN - EXIT - ELSE - string(i:i) = array(i) - END IF - END DO +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get groupd name associated with a GID +! +!# System_Getgrgid +! +! The System_Getgrgid() function returns a string containing the group +! name associated with the given GID. If no match is found +! it returns a null string and sets errno to indicate the error. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getgrgid_test_1.F90" %}} +!``` -END FUNCTION arr2str +INTERFACE + MODULE FUNCTION System_Getgrgid(gid) RESULT(gname) + CLASS(*), INTENT(in) :: gid + !! GID to try to look up associated group for. Can be of any + !! INTEGER type. + CHARACTER(len=:), ALLOCATABLE :: gname + !! returns the group name. Blank if an error occurs + END FUNCTION System_Getgrgid +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getpwuid@GetMethods !---------------------------------------------------------------------------- -PURE FUNCTION str2_carr(string) RESULT(array) - -! ident_32="@(#)M_system::str2_carr(3fp): function copies string to null terminated char array" - - CHARACTER(len=*), INTENT(in) :: string - CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) - INTEGER :: i - - DO i = 1, LEN_TRIM(string) - array(i) = string(i:i) - END DO - array(i:i) = C_NULL_CHAR +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get login name associated with a UID +! +!# System_Getpwuid +! +! The system_getpwuid() function returns a string containing the user +! name associated with the given UID. If no match is found it returns +! a null string and sets errno to indicate the error. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getpwuid_test_1.F90" %}} +!``` -END FUNCTION str2_carr +INTERFACE + MODULE FUNCTION System_Getpwuid(uid) RESULT(uname) + CLASS(*), INTENT(in) :: uid + !! UID to try to look up associated username for. Can be of any + !! INTEGER type. + CHARACTER(len=:), ALLOCATABLE :: uname + !! returns the login name. + END FUNCTION System_Getpwuid +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Stat !---------------------------------------------------------------------------- -FUNCTION C2F_string(c_string_pointer) RESULT(f_string) - -! gets a C string (pointer), and returns the corresponding Fortran string up to 4096(max_len) characters; -! If the C string is null, it returns string C "null" character: - - TYPE(C_PTR), INTENT(in) :: c_string_pointer - CHARACTER(len=:), ALLOCATABLE :: f_string - CHARACTER(kind=C_CHAR), DIMENSION(:), POINTER :: char_array_pointer => NULL() - INTEGER, PARAMETER :: max_len = 4096 - CHARACTER(len=max_len) :: aux_string - INTEGER :: i - INTEGER :: length - - length = 0 - CALL C_F_POINTER(c_string_pointer, char_array_pointer, [max_len]) - - IF (.NOT. ASSOCIATED(char_array_pointer)) THEN - IF (ALLOCATED(f_string)) DEALLOCATE (f_string) - ALLOCATE (CHARACTER(len=4) :: f_string) - f_string = C_NULL_CHAR - RETURN - END IF - - aux_string = " " - - DO i = 1, max_len - IF (char_array_pointer(i) == C_NULL_CHAR) THEN - length = i - 1; EXIT - END IF - aux_string(i:i) = char_array_pointer(i) - END DO +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get file status information +! +!# System_Stat +! +! This function returns information about a file. No permissions are +! required on the file itself, but execute (search) permission is required +! on all of the directories in path that lead to the file. The elements +! that are obtained and stored in the array VALUES: +! +! | Index | VALUES(n) | Description | +! |-------|-----------|-------------| +! | 1 | VALUES(1) | Device ID | +! | 2 | VALUES(2) | Inode number | +! | 3 | VALUES(3) | File mode | +! | 4 | VALUES(4) | Number of links | +! | 5 | VALUES(5) | Owner UID | +! | 6 | VALUES(6) | Owner GID | +! | 7 | VALUES(7) | ID of device containing dir entry for file | +! | 8 | VALUES(8) | File size (bytes) | +! | 9 | VALUES(9) | Last access time as a Unix Epoch time (seconds) | +! | 10 | VALUES(10) | Last modification time as a Unix Epoch time (seconds) | +! | 11 | VALUES(11) | Last file status change time as a Unix Epoch time | +! | 12 | VALUES(12) | Preferred I/O block size (-1 if not available) | +! | 13 | VALUES(13) | Number of blocks allocated (-1 if not available) | +! +! > [!NOTE] +! > Not all these elements are relevant on all systems. +! > If an element is not relevant, it is returned as `0`.!! +! +! +!## Examples +! +! ```fortran +! {{% fortran-code file="examples/System_Stat_test_1.F90" %}} +! ``` - IF (ALLOCATED(f_string)) DEALLOCATE (f_string) - ALLOCATE (CHARACTER(len=length) :: f_string) - f_string = aux_string(1:length) -END FUNCTION C2F_string +INTERFACE + MODULE SUBROUTINE System_Stat(pathname, values, ierr) + CHARACTER(len=*), INTENT(IN) :: pathname + !! The type shall be CHARACTER, of the default kind and a valid + !! path within the file system. + INTEGER(kind=INT64), INTENT(OUT) :: values(13) + !! VALUES The type shall be INTEGER(8), DIMENSION(13). + INTEGER, OPTIONAL, INTENT(OUT) :: ierr + END SUBROUTINE System_Stat +END INTERFACE !---------------------------------------------------------------------------- -! +! System_Dir !---------------------------------------------------------------------------- -!> -!!##NAME -!! SYSTEM_STAT - [M_system:QUERY_FILE] Get file status information -!! (LICENSE:PD) -!! -!!##SYNTAX -!! CALL SYSTEM_STAT(NAME, VALUES [, STATUS],[DEBUG]) -!! -!! character(len=*),intent(in) :: NAME -!! integer(kind=int64),intent(out) :: values(13) -!! integer,optional,intent(out) :: status -!! integer,intent(in) :: debug -!! -!!##DESCRIPTION -!! -!! This function returns information about a file. No permissions are -!! required on the file itself, but execute (search) permission is required -!! on all of the directories in path that lead to the file. The elements -!! that are obtained and stored in the array VALUES: -!! -!! VALUES(1) Device ID -!! VALUES(2) Inode number -!! VALUES(3) File mode -!! VALUES(4) Number of links -!! VALUES(5) Owner uid -!! VALUES(6) Owner gid -!! VALUES(7) ID of device containing directory entry for file (0 if not available) -!! VALUES(8) File size (bytes) -!! VALUES(9) Last access time as a Unix Epoch time rounded to seconds -!! VALUES(10) Last modification time as a Unix Epoch time rounded to seconds -!! VALUES(11) Last file status change time as a Unix Epoch time rounded to seconds -!! VALUES(12) Preferred I/O block size (-1 if not available) -!! VALUES(13) Number of blocks allocated (-1 if not available) -!! -!! Not all these elements are relevant on all systems. If an element is -!! not relevant, it is returned as 0. -!! -!!##OPTIONS -!! -!! NAME The type shall be CHARACTER, of the default kind and a valid -!! path within the file system. -!! VALUES The type shall be INTEGER(8), DIMENSION(13). -!! STATUS (Optional) status flag of type INTEGER(4). Returns 0 on success -!! and a system specific error code otherwise. -!! DEBUG (Optional) print values being returned from C routine being -!! called if value of 0 is used -!! -!!##EXAMPLE -!! -!! program demo_system_stat -!! -!! use M_system, only : system_stat, system_getpwuid, system_getgrgid -!! use M_time, only : fmtdate, u2d -!! use, intrinsic :: iso_fortran_env, only : int32, int64 -!! implicit none -!! -!! integer(kind=int64) :: buff(13) -!! integer(kind=int32) :: status -!! character(len=*),parameter :: fmt_date='year-month-day hour:minute:second' -!! -!! integer(kind=int64) :: & -!! Device_ID, Inode_number, File_mode, Number_of_links, -!! Owner_uid, & -!! Owner_gid, Directory_device, File_size, Last_access, -!! Last_modification,& -!! Last_status_change, Preferred_block_size, Number_of_blocks_allocated -!! equivalence & -!! ( buff(1) , Device_ID ) , & -!! ( buff(2) , Inode_number ) , & -!! ( buff(3) , File_mode ) , & -!! ( buff(4) , Number_of_links ) , & -!! ( buff(5) , Owner_uid ) , & -!! ( buff(6) , Owner_gid ) , & -!! ( buff(7) , Directory_device ) , & -!! ( buff(8) , File_size ) , & -!! ( buff(9) , Last_access ) , & -!! ( buff(10) , Last_modification ) , & -!! ( buff(11) , Last_status_change ) , & -!! ( buff(12) , Preferred_block_size ) , & -!! ( buff(13) , Number_of_blocks_allocated ) -!! -!! CALL SYSTEM_STAT("/etc/hosts", buff, status) -!! -!! if (status == 0) then -!! write (*, FMT="('Device ID(hex/decimal):', & -!! & T30, Z0,'h/',I0,'d')") buff(1),buff(1) -!! write (*, FMT="('Inode number:', & -!! & T30, I0)") buff(2) -!! write (*, FMT="('File mode (octal):', & -!! & T30, O19)") buff(3) -!! write (*, FMT="('Number of links:', & -!! & T30, I0)") buff(4) -!! write (*, FMT="('Owner''s uid/username:', & -!! & T30, I0,1x, A)") buff(5), system_getpwuid(buff(5)) -!! write (*, FMT="('Owner''s gid/group:', & -!! & T30, I0,1x, A)") buff(6), system_getgrgid(buff(6)) -!! write (*, FMT="('Device where located:', & -!! & T30, I0)") buff(7) -!! write (*, FMT="('File size(bytes):', & -!! & T30, I0)") buff(8) -!! write (*, FMT="('Last access time:', & -!! & T30, I0,1x, A)") buff(9), fmtdate(u2d(int(buff(9))),fmt_date) -!! write (*, FMT="('Last modification time:', & -!! & T30, I0,1x, A)") buff(10),fmtdate(u2d(int(buff(10))),fmt_date) -!! write (*, FMT="('Last status change time:', & -!! & T30, I0,1x, A)") buff(11),fmtdate(u2d(int(buff(11))),fmt_date) -!! write (*, FMT="('Preferred block size(bytes):', & -!! & T30, I0)") buff(12) -!! write (*, FMT="('No. of blocks allocated:', & -!! & T30, I0)") buff(13) -!! endif -!! -!! end program demo_system_stat -!! -!! Results: -!! -!! Device ID(hex/decimal): 3E6BE045h/1047257157d -!! Inode number: 1407374886070599 -!! File mode (octal): 100750 -!! Number of links: 1 -!! Owner uid/username: 18 SYSTEM -!! Owner gid/group: 18 SYSTEM -!! Device where located: 0 -!! File size(bytes): 824 -!! Last access time: 1557983191 2019-05-16 01:06:31 -!! Last modification time: 1557983191 2019-05-16 01:06:31 -!! Last status change time: 1557983532 2019-05-16 01:12:12 -!! Preferred block size(bytes): 65536 -!! No. of blocks allocated: 4 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain - -SUBROUTINE system_stat(pathname, values, ierr) - IMPLICIT NONE - -! ident_33="@(#)M_system::system_stat(3f): call stat(3c) to get pathname information" - - CHARACTER(len=*), INTENT(in) :: pathname - - INTEGER(kind=INT64), INTENT(out) :: values(13) - INTEGER(kind=C_LONG) :: cvalues(13) - - INTEGER, OPTIONAL, INTENT(out) :: ierr - INTEGER(kind=C_INT) :: cierr +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Return filenames in a directory matching specific wildcard strings +! +!# System_Dir +! +! returns an array of filenames in the specified directory matching +! the wildcard string (which defaults to "*"). +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Dir_test_1.F90" %}} +!``` - INTERFACE - SUBROUTINE c_stat(buffer, cvalues, cierr, cdebug) BIND(c, name="my_stat") - IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT, C_LONG - CHARACTER(kind=C_CHAR), INTENT(in) :: buffer(*) - INTEGER(kind=C_LONG), INTENT(out) :: cvalues(*) - INTEGER(kind=C_INT) :: cierr - INTEGER(kind=C_INT), INTENT(in) :: cdebug - END SUBROUTINE c_stat - END INTERFACE -!----------------------------------------------------------------------------------------------------------------------------------- - CALL c_stat(str2_carr(TRIM(pathname)), cvalues, cierr, 0_C_INT) - values = cvalues - IF (PRESENT(ierr)) THEN - ierr = cierr - END IF -END SUBROUTINE system_stat +INTERFACE + MODULE FUNCTION System_Dir(directory, pattern) + CHARACTER(*), INTENT(IN), OPTIONAL :: directory + !! name of directory to match filenames in. Defaults to ".". + CHARACTER(*), INTENT(IN), OPTIONAL :: pattern + !! wildcard string matching the rules of the matchw(3f) function. + !! Basically "*" matches anything, "?" matches any single character + CHARACTER(:), ALLOCATABLE :: System_Dir(:) + !!System_Dir An array right-padded to the length of the longest + !!filename. Note that this means filenames actually containing + !!trailing spaces in their names may be incorrect. + END FUNCTION System_Dir +END INTERFACE !---------------------------------------------------------------------------- -! +! Matchw@UtilityMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_dir(3f) - [M_io] return filenames in a directory matching specified wildcard string -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_dir(directory,pattern) -!! -!! character(len=*),intent(in),optional :: directory -!! character(len=*),intent(in),optional :: pattern -!! character(len=:),allocatable :: system_dir(:) -!! -!!##DESCRIPTION -!! returns an array of filenames in the specified directory matching -!! the wildcard string (which defaults to "*"). -!! -!!##OPTIONS -!! DIRECTORY name of directory to match filenames in. Defaults to ".". -!! PATTERN wildcard string matching the rules of the matchw(3f) function. Basically -!! o "*" matches anything -!! o "?" matches any single character -!! -!!##RETURNS -!! system_dir An array right-padded to the length of the longest -!! filename. Note that this means filenames actually containing -!! trailing spaces in their names may be incorrect. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_dir -!! use M_system, only : system_dir -!! implicit none -!! write(*, '(a)')system_dir(pattern='*.F90') -!! end program demo_system_dir -!! -!!##AUTHOR -!! John S. Urban -!! -!!##LICENSE -!! Public Domain - -FUNCTION system_dir(directory, pattern) -!use M_system, only : system_opendir, system_readdir, system_rewinddir, system_closedir - USE ISO_C_BINDING - IMPLICIT NONE - CHARACTER(len=*), INTENT(in), OPTIONAL :: directory - CHARACTER(len=*), INTENT(in), OPTIONAL :: pattern - CHARACTER(len=:), ALLOCATABLE :: system_dir(:) - CHARACTER(len=:), ALLOCATABLE :: wild - TYPE(C_PTR) :: dir - CHARACTER(len=:), ALLOCATABLE :: filename - INTEGER :: i, ierr, icount, longest - longest = 0 - icount = 0 - IF (PRESENT(pattern)) THEN - wild = pattern - ELSE - wild = '*' - END IF - IF (PRESENT(directory)) THEN !--- open directory stream to read from - CALL system_opendir(directory, dir, ierr) - ELSE - CALL system_opendir('.', dir, ierr) - END IF - IF (ierr .EQ. 0) THEN - DO i = 1, 2 !--- read directory stream twice, first time to get size - DO - CALL system_readdir(dir, filename, ierr) - IF (filename .EQ. ' ') EXIT - IF (wild .NE. '*') THEN - IF (.NOT. matchw(filename, wild)) CYCLE ! Call a wildcard matching routine. - END IF - icount = icount + 1 - SELECT CASE (i) - CASE (1) - longest = MAX(longest, LEN(filename)) - CASE (2) - system_dir(icount) = filename - END SELECT - END DO - IF (i .EQ. 1) THEN - CALL system_rewinddir(dir) - IF (ALLOCATED(system_dir)) DEALLOCATE (system_dir) - ALLOCATE (CHARACTER(len=longest) :: system_dir(icount)) - icount = 0 - END IF - END DO - END IF - CALL system_closedir(dir, ierr) !--- close directory stream -END FUNCTION system_dir +INTERFACE + MODULE FUNCTION Matchw(tame, wild) + LOGICAL :: Matchw + CHARACTER(len=*) :: tame + !! A string without wildcards + CHARACTER(len=*) :: wild + !! A (potentially) corresponding string with wildcards + END FUNCTION Matchw +END INTERFACE !---------------------------------------------------------------------------- -! +! Anyinteger_to_64bit@UtilityMethods !---------------------------------------------------------------------------- -! copied from M_strings.ff to make stand-alone github version -FUNCTION matchw(tame, wild) -! ident_34="@(#)M_strings::matchw(3f): function compares text strings, one of which can have wildcards ('*' or '?')." - LOGICAL :: matchw - CHARACTER(len=*) :: tame ! A string without wildcards - CHARACTER(len=*) :: wild ! A (potentially) corresponding string with wildcards - CHARACTER(len=LEN(tame) + 1) :: tametext - CHARACTER(len=LEN(wild) + 1) :: wildtext - CHARACTER(len=1), PARAMETER :: NULL = CHAR(0) - INTEGER :: wlen - INTEGER :: ti, wi - INTEGER :: i - CHARACTER(len=:), ALLOCATABLE :: tbookmark, wbookmark -! These two values are set when we observe a wildcard character. They -! represent the locations, in the two strings, from which we start once we've observed it. - tametext = tame//NULL - wildtext = wild//NULL - tbookmark = NULL - wbookmark = NULL - wlen = LEN(wild) - wi = 1 - ti = 1 - DO ! Walk the text strings one character at a time. - IF (wildtext(wi:wi) == '*') THEN ! How do you match a unique text string? - DO i = wi, wlen ! Easy: unique up on it! - IF (wildtext(wi:wi) .EQ. '*') THEN - wi = wi + 1 - ELSE - EXIT - END IF - END DO - IF (wildtext(wi:wi) .EQ. NULL) THEN ! "x" matches "*" - matchw = .TRUE. - RETURN - END IF - IF (wildtext(wi:wi) .NE. '?') THEN - ! Fast-forward to next possible match. - DO WHILE (tametext(ti:ti) .NE. wildtext(wi:wi)) - ti = ti + 1 - IF (tametext(ti:ti) .EQ. NULL) THEN - matchw = .FALSE. - RETURN ! "x" doesn't match "*y*" - END IF - END DO - END IF - wbookmark = wildtext(wi:) - tbookmark = tametext(ti:) - elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then - ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. - IF (wbookmark .NE. NULL) THEN - IF (wildtext(wi:) .NE. wbookmark) THEN - wildtext = wbookmark; - wlen = LEN_TRIM(wbookmark) - wi = 1 - ! Don't go this far back again. - IF (tametext(ti:ti) .NE. wildtext(wi:wi)) THEN - tbookmark = tbookmark(2:) - tametext = tbookmark - ti = 1 - CYCLE ! "xy" matches "*y" - ELSE - wi = wi + 1 - END IF - END IF - IF (tametext(ti:ti) .NE. NULL) THEN - ti = ti + 1 - CYCLE ! "mississippi" matches "*sip*" - END IF - END IF - matchw = .FALSE. - RETURN ! "xy" doesn't match "x" - END IF - ti = ti + 1 - wi = wi + 1 - IF (tametext(ti:ti) .EQ. NULL) THEN ! How do you match a tame text string? - IF (wildtext(wi:wi) .NE. NULL) THEN - DO WHILE (wildtext(wi:wi) == '*') ! The tame way: unique up on it! - wi = wi + 1 ! "x" matches "x*" - IF (wildtext(wi:wi) .EQ. NULL) EXIT - END DO - END IF - IF (wildtext(wi:wi) .EQ. NULL) THEN - matchw = .TRUE. - RETURN ! "x" matches "x" - END IF - matchw = .FALSE. - RETURN ! "x" doesn't match "xy" - END IF - END DO -END FUNCTION matchw +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Convert integer any kind to integer +! +!# Anyinteger_to_64bit +! +! This function uses polymorphism to allow arguments of different types +! generically. It is used to create other procedures that can take +! many scalar arguments as input options, equivalent to passing the +! parameter VALUE as INT(VALUE,0_int64). + +INTERFACE + MODULE PURE ELEMENTAL FUNCTION Anyinteger_to_64bit(intin) RESULT(ii38) + CLASS(*), INTENT(in) :: intin + !! Input argument of a procedure to convert to type + !! INTEGER(KIND=int64). May be of KIND kind=int8, kind=int16, + !! kind=int32, kind=int64. + INTEGER(kind=INT64) :: ii38 + !! The value of VALUIN converted to INTEGER(KIND=INT64). + END FUNCTION Anyinteger_to_64bit +END INTERFACE !---------------------------------------------------------------------------- -! +! f_handler@UtilityMethods !---------------------------------------------------------------------------- -!>NAME -!! -!! anyinteger_to_64bit(3f) - [M_anything] convert integer any kind to integer(kind=int64) -!! (LICENSE:PD) -!! -!!SYNOPSIS -!! -!! pure elemental function anyinteger_to_64bit(intin) result(ii38) -!! -!! integer(kind=int64) function anyinteger_to_64bit(value) -!! class(*),intent(in) :: intin -!! integer(kind=int8|int16|int32|int64) :: value -!! -!!DESCRIPTION -!! -!! This function uses polymorphism to allow arguments of different types -!! generically. It is used to create other procedures that can take -!! many scalar arguments as input options, equivalent to passing the -!! parameter VALUE as int(VALUE,0_int64). -!! -!!OPTIONS -!! -!! VALUEIN input argument of a procedure to convert to type INTEGER(KIND=int64). -!! May be of KIND kind=int8, kind=int16, kind=int32, kind=int64. -!!RESULTS -!! The value of VALUIN converted to INTEGER(KIND=INT64). -!!EXAMPLE -!! Sample program -!! -!! program demo_anyinteger_to_64bit -!! use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64 -!! implicit none -!! ! call same function with many scalar input types -!! write(*,*)squarei(huge(0_int8)),huge(0_int8) , & -!! & '16129' -!! write(*,*)squarei(huge(0_int16)),huge(0_int16) , & -!! & '1073676289' -!! write(*,*)squarei(huge(0_int32)),huge(0_int32) , & -!! & '4611686014132420609' -!! write(*,*)squarei(huge(0_int64)),huge(0_int64) , & -!! & '85070591730234615847396907784232501249' -!! contains -!! ! -!! function squarei(invalue) -!! use M_anything, only : anyinteger_to_64bit -!! class(*),intent(in) :: invalue -!! doubleprecision :: invalue_local -!! doubleprecision :: squarei -!! invalue_local=anyinteger_to_64bit(invalue) -!! squarei=invalue_local*invalue_local -!! end function squarei -!! ! -!! end program demo_anyinteger_to_64bit -!! -!! Results -!! -!! 16129.000000000000 127 \ -!! 16129 -!! 1073676289.0000000 32767 \ -!! 1073676289 -!! 4.6116860141324206E+018 2147483647 \ -!! 4611686014132420609 -!! 8.5070591730234616E+037 9223372036854775807 \ -!! 85070591730234615847396907784232501249 -!! 2.8948022309329049E+076 170141183460469231731687303715884105727 \ -!! 28948022309329048855892746252171976962977213799489202546401021394546514198529 -!! -!!AUTHOR -!! John S. Urban -!!LICENSE -!! Public Domain - -PURE ELEMENTAL FUNCTION anyinteger_to_64bit(intin) RESULT(ii38) - USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: ERROR_UNIT !! ,input_unit,output_unit - IMPLICIT NONE - -!!@(#) M_anything::anyinteger_to_64(3f): convert integer parameter of any kind to 64-bit integer - - CLASS(*), INTENT(in) :: intin - INTEGER(kind=INT64) :: ii38 - SELECT TYPE (intin) - TYPE is (INTEGER(kind=INT8)); ii38 = INT(intin, kind=INT64) - TYPE is (INTEGER(kind=INT16)); ii38 = INT(intin, kind=INT64) - TYPE is (INTEGER(kind=INT32)); ii38 = intin - TYPE is (INTEGER(kind=INT64)); ii38 = intin - !class default - !write(error_unit,*)'ERROR: unknown integer type' - !stop 'ERROR: *anyinteger_to_64* unknown integer type' - END SELECT -END FUNCTION anyinteger_to_64bit +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: handler + +INTERFACE + MODULE SUBROUTINE f_handler(signum) BIND(c) + INTEGER(C_INT), INTENT(IN), VALUE :: signum + END SUBROUTINE f_handler +END INTERFACE !---------------------------------------------------------------------------- ! diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index ac3d6e7fb..6a0e2cb91 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -15,6 +15,9 @@ # this program. If not, see # +# System +include(${CMAKE_CURRENT_LIST_DIR}/System/CMakeLists.txt) + # TriangleInterface include(${CMAKE_CURRENT_LIST_DIR}/TriangleInterface/CMakeLists.txt) diff --git a/src/submodules/System/CMakeLists.txt b/src/submodules/System/CMakeLists.txt index 411f9b180..d323777cc 100644 --- a/src/submodules/System/CMakeLists.txt +++ b/src/submodules/System/CMakeLists.txt @@ -19,8 +19,10 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE - ${src_path}/System_Method@GetMethods.F90 - ${src_path}/System_Method@SetMethods.F90 - ${src_path}/System_Method@EnquiryMethods.F90 + PRIVATE ${src_path}/System_Method@SignalMethods.F90 + PRIVATE ${src_path}/System_Method@EnquiryMethods.F90 + PRIVATE ${src_path}/System_Method@FileMethods.F90 + PRIVATE ${src_path}/System_Method@GetMethods.F90 + PRIVATE ${src_path}/System_Method@UtilityMethods.F90 + PRIVATE ${src_path}/System_Method@EnvironmentMethods.F90 ) diff --git a/src/submodules/System/src/System_Method@EnquiryMethods.F90 b/src/submodules/System/src/System_Method@EnquiryMethods.F90 index e69de29bb..eb60ebebb 100644 --- a/src/submodules/System/src/System_Method@EnquiryMethods.F90 +++ b/src/submodules/System/src/System_Method@EnquiryMethods.F90 @@ -0,0 +1,200 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(System_Method) EnquiryMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! System_Access +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Access +IF (C_Access(str2_carr(TRIM(pathname)), INT(amode, kind=C_INT)) .EQ. 0) THEN + system_access = .TRUE. +ELSE + system_access = .FALSE. +END IF +END PROCEDURE System_Access + +!---------------------------------------------------------------------------- +! System_Issock +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Issock +IF (c_issock(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_issock = .TRUE. +ELSE + system_issock = .FALSE. +END IF +END PROCEDURE System_Issock + +!---------------------------------------------------------------------------- +! System_Isfifo +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_isfifo + +INTERFACE + FUNCTION c_isfifo(pathname) BIND(C, name="my_isfifo") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isfifo +END INTERFACE + +IF (c_isfifo(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_isfifo = .TRUE. +ELSE + system_isfifo = .FALSE. +END IF + +END PROCEDURE system_isfifo + +!---------------------------------------------------------------------------- +! System_Ischr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Ischr +INTERFACE + FUNCTION c_ischr(pathname) BIND(C, name="my_ischr") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_ischr +END INTERFACE + +IF (c_ischr(str2_carr(TRIM(pathname))) .EQ. 1) THEN + System_Ischr = .TRUE. +ELSE + System_Ischr = .FALSE. +END IF +END PROCEDURE System_Ischr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_isreg +INTERFACE + FUNCTION c_isreg(pathname) BIND(C, name="my_isreg") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isreg +END INTERFACE + +IF (c_isreg(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_isreg = .TRUE. +ELSE + system_isreg = .FALSE. +END IF +END PROCEDURE system_isreg + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Islnk +INTERFACE + FUNCTION c_islnk(pathname) BIND(C, name="my_islnk") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_islnk +END INTERFACE + +IF (c_islnk(str2_carr(TRIM(pathname))) .EQ. 1) THEN + System_Islnk = .TRUE. +ELSE + System_Islnk = .FALSE. +END IF +END PROCEDURE System_Islnk + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Isblk +INTERFACE + FUNCTION c_isblk(pathname) BIND(C, name="my_isblk") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isblk +END INTERFACE + +IF (c_isblk(str2_carr(TRIM(pathname))) .EQ. 1) THEN + system_isblk = .TRUE. +ELSE + system_isblk = .FALSE. +END IF +END PROCEDURE System_Isblk + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Isdir +INTERFACE + FUNCTION c_isdir(dirname) BIND(C, name="my_isdir") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: dirname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_isdir +END INTERFACE + +IF (c_isdir(str2_carr(TRIM(dirname))) .EQ. 1) THEN + System_Isdir = .TRUE. +ELSE + System_Isdir = .FALSE. +END IF +END PROCEDURE System_Isdir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getcwd +INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG +CHARACTER(kind=C_CHAR, len=1) :: buffer(length) +TYPE(C_PTR) :: buffer2 +INTERFACE + FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) + IMPORT C_CHAR, C_SIZE_T, C_PTR + CHARACTER(kind=C_CHAR), INTENT(out) :: buffer(*) + INTEGER(C_SIZE_T), VALUE, INTENT(in) :: size + TYPE(C_PTR) :: buffer_result + END FUNCTION +END INTERFACE + +buffer = ' ' +buffer2 = c_getcwd(buffer, length) +IF (.NOT. C_ASSOCIATED(buffer2)) THEN + output = '' + ierr = -1 +ELSE + output = TRIM(arr2str(buffer)) + ierr = 0 +END IF +END PROCEDURE system_getcwd + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE EnquiryMethods diff --git a/src/submodules/System/src/System_Method@EnviormentMethods.F90 b/src/submodules/System/src/System_Method@EnviormentMethods.F90 new file mode 100644 index 000000000..49ee3ad2e --- /dev/null +++ b/src/submodules/System/src/System_Method@EnviormentMethods.F90 @@ -0,0 +1,180 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +SUBMODULE(System_Method) EnvironmentMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_putenv +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: c_string(*) + END FUNCTION +END INTERFACE + +INTEGER :: loc_err +INTEGER :: i + +! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit +CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) + +ALLOCATE (memleak(LEN(string) + 1)) +DO i = 1, LEN(string) + memleak(i) = string(i:i) +END DO +memleak(LEN(string) + 1) = C_NULL_CHAR + +loc_err = c_putenv(memleak) +IF (PRESENT(err)) err = loc_err +END PROCEDURE system_putenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getenv +INTEGER :: howbig +INTEGER :: stat + +IF (NAME .NE. '') THEN + call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value + IF (howbig .NE. 0) THEN + SELECT CASE (stat) + CASE (1) + ! print *, NAME, " is not defined in the environment. Strange..." + VALUE = '' + CASE (2) + ! print *, "This processor doesn't support environment variables. Boooh!" + VALUE = '' + CASE default + ! make string to hold value of sufficient size and get value + IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) + ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) + CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) + IF (stat .NE. 0) VALUE = '' + END SELECT + ELSE + VALUE = '' + END IF +ELSE + VALUE = '' +END IF +IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default +END PROCEDURE system_getenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE set_environment_variable +INTEGER :: loc_err + +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: c_name(*) + CHARACTER(kind=C_CHAR) :: c_VALUE(*) + END FUNCTION +END INTERFACE + +loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) +IF (PRESENT(STATUS)) STATUS = loc_err + +END PROCEDURE set_environment_variable + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_clearenv +! emulating because not available on some platforms +CHARACTER(len=:), ALLOCATABLE :: string +INTEGER :: ierr_local1, ierr_local2 + +ierr_local2 = 0 + +INFINITE: DO + CALL system_initenv() + ! important -- changing table causes undefined behavior + ! so reset after each unsetenv + string = system_readenv() + ! get first name=value pair + IF (string .EQ. '') EXIT INFINITE + CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair + IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 +END DO INFINITE + +IF (PRESENT(ierr)) THEN + ierr = ierr_local2 +ELSEIF (ierr_local2 .NE. 0) THEN +! if error occurs and not being returned, stop + WRITE (*, *) '*system_clearenv* error=', ierr_local2 + STOP +END IF +END PROCEDURE system_clearenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_unsetenv +INTEGER :: ierr_local + +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") + IMPORT C_INT, C_CHAR + CHARACTER(len=1, kind=C_CHAR) :: c_name(*) + END FUNCTION +END INTERFACE + +ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) + +IF (PRESENT(ierr)) THEN + ierr = ierr_local +ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop + WRITE (*, *) '*system_unsetenv* error=', ierr_local + STOP +END IF + +END PROCEDURE system_unsetenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_readenv +CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) + +INTERFACE + SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') + IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T + CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) + END SUBROUTINE c_readenv +END INTERFACE + +c_buff = ' ' +c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR +CALL c_readenv(c_buff) +string = TRIM(arr2str(c_buff)) +END PROCEDURE system_readenv + +END SUBMODULE EnvironmentMethods diff --git a/src/submodules/System/src/System_Method@EnvironmentMethods.F90 b/src/submodules/System/src/System_Method@EnvironmentMethods.F90 new file mode 100644 index 000000000..8126207b4 --- /dev/null +++ b/src/submodules/System/src/System_Method@EnvironmentMethods.F90 @@ -0,0 +1,50 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +SUBMODULE(System_Method) EnvironmentMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_putenv +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: c_string(*) + END FUNCTION +END INTERFACE + +INTEGER :: loc_err +INTEGER :: i + +! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit +CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) + +ALLOCATE (memleak(LEN(string) + 1)) +DO i = 1, LEN(string) + memleak(i) = string(i:i) +END DO +memleak(LEN(string) + 1) = C_NULL_CHAR + +loc_err = c_putenv(memleak) +IF (PRESENT(err)) err = loc_err +END PROCEDURE system_putenv + +END SUBMODULE EnvironmentMethods diff --git a/src/submodules/System/src/System_Method@FileMethods.F90 b/src/submodules/System/src/System_Method@FileMethods.F90 new file mode 100644 index 000000000..95ed5989f --- /dev/null +++ b/src/submodules/System/src/System_Method@FileMethods.F90 @@ -0,0 +1,414 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(System_Method) FileMethods +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! System_Utime +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Utime +INTEGER(kind=8) :: times_local(2) +LOGICAL :: isok + +!-! int my_utime(const char *path, int times[2]) +IF (PRESENT(times)) THEN + times_local = times +ELSE + times_local = timestamp() +END IF + +isok = c_utime(str2_carr(TRIM(pathname)), INT(times_local, kind=C_INT)) .EQ. 0 +IF (isok) THEN + system_utime = .TRUE. +ELSE + system_utime = .FALSE. +END IF +END PROCEDURE System_Utime + +!---------------------------------------------------------------------------- +! System_RealPath +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_RealPath +TYPE(C_PTR) :: c_output +c_output = C_RealPath(str2_carr(TRIM(input))) +IF (.NOT. C_ASSOCIATED(c_output)) THEN + string = CHAR(0) +ELSE + string = C2F_string(c_output) +END IF +END PROCEDURE System_RealPath + +!---------------------------------------------------------------------------- +! System_Chown +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Chown +LOGICAL :: isok + +INTERFACE + function c_chown(c_dirname,c_owner,c_group) bind (C,name="my_chown") result (c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_dirname(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: c_owner + INTEGER(kind=C_INT), INTENT(in), VALUE :: c_group + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_chown +END INTERFACE + +isok = c_chown( & + str2_carr(TRIM(dirname)), & + INT(owner, kind=C_INT), & + INT(group, kind=C_INT)) .EQ. 1 + +IF (isok) THEN + System_Chown = .TRUE. +ELSE + System_Chown = .FALSE. +END IF + +END PROCEDURE System_Chown + +!---------------------------------------------------------------------------- +! System_Chdir +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_chdir +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_chdir(c_path) BIND(C, name="chdir") + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR) :: c_path(*) + END FUNCTION +END INTERFACE + +INTEGER :: loc_err + +loc_err = c_chdir(str2_carr(TRIM(path))) +IF (PRESENT(err)) THEN + err = loc_err +END IF +END PROCEDURE system_chdir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_remove +INTERFACE + FUNCTION c_remove(c_path) BIND(c, name="remove") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) + INTEGER(C_INT) :: c_err + END FUNCTION +END INTERFACE + +err = c_remove(str2_carr(TRIM(path))) +END PROCEDURE system_remove + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_rename +INTERFACE + FUNCTION c_rename(c_input, c_output) BIND(c, name="rename") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) + CHARACTER(kind=C_CHAR), INTENT(in) :: c_output(*) + INTEGER(C_INT) :: c_err + END FUNCTION +END INTERFACE + +ierr = c_rename(str2_carr(TRIM(input)), str2_carr(TRIM(output))) +END PROCEDURE system_rename + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_chmod +INTERFACE + FUNCTION c_chmod(c_filename, c_mode) BIND(c, name="chmod") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: c_filename(*) + INTEGER(C_INT), VALUE, INTENT(in) :: c_mode + INTEGER(C_INT) :: c_err + END FUNCTION +END INTERFACE + +ierr = c_chmod(str2_carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) +END PROCEDURE system_chmod + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_rmdir +INTERFACE + FUNCTION c_rmdir(c_path) BIND(c, name="rmdir") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) + INTEGER(C_INT) :: c_err + END FUNCTION +END INTERFACE + +err = c_rmdir(str2_carr(TRIM(dirname))) +IF (err .NE. 0) err = system_errno() +END PROCEDURE system_rmdir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_mkfifo +INTEGER :: c_mode +INTERFACE + FUNCTION c_mkfifo(c_path, c_mode) BIND(c, name="mkfifo") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_mode + INTEGER(C_INT) :: c_err + END FUNCTION c_mkfifo +END INTERFACE + +c_mode = mode +err = c_mkfifo(str2_carr(TRIM(pathname)), c_mode) +END PROCEDURE system_mkfifo + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_mkdir +INTEGER :: c_mode +INTEGER(kind=C_INT) :: err + +INTERFACE + FUNCTION c_mkdir(c_path, c_mode) BIND(c, name="mkdir") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(len=1, kind=C_CHAR), INTENT(in) :: c_path(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_mode + INTEGER(C_INT) :: c_err + END FUNCTION c_mkdir +END INTERFACE + +INTERFACE + SUBROUTINE my_mkdir(string, c_mode, c_err) BIND(C, name="my_mkdir") + USE ISO_C_BINDING, ONLY: C_CHAR, C_INT + CHARACTER(kind=C_CHAR) :: string(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_mode + INTEGER(C_INT) :: c_err + END SUBROUTINE my_mkdir +END INTERFACE + +c_mode = mode +IF (INDEX(dirname, '/') .NE. 0) THEN + CALL my_mkdir(str2_carr(TRIM(dirname)), c_mode, err) +ELSE + err = c_mkdir(str2_carr(TRIM(dirname)), c_mode) +END IF +ierr = err ! c_int to default integer kind +END PROCEDURE system_mkdir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_opendir +INTERFACE + FUNCTION c_opendir(c_dirname) BIND(c, name="opendir") RESULT(c_dir) + IMPORT C_CHAR, C_INT, C_PTR + CHARACTER(kind=C_CHAR), INTENT(in) :: c_dirname(*) + TYPE(C_PTR) :: c_dir + END FUNCTION c_opendir +END INTERFACE + +ierr = 0 +dir = c_opendir(str2_carr(TRIM(dirname))) +IF (.NOT. C_ASSOCIATED(dir)) THEN + WRITE (*, '(a)') '*system_opendir* Error opening '//TRIM(dirname) + ierr = -1 +END IF +END PROCEDURE system_opendir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_readdir +INTEGER(kind=C_INT) :: ierr_local +CHARACTER(kind=C_CHAR, len=1) :: buf(4097) + +INTERFACE + SUBROUTINE c_readdir(c_dir, c_filename, c_ierr) BIND(C, NAME='my_readdir') + IMPORT C_CHAR, C_INT, C_PTR + TYPE(C_PTR), VALUE :: c_dir + CHARACTER(kind=C_CHAR) :: c_filename(*) + INTEGER(kind=C_INT) :: c_ierr + END SUBROUTINE c_readdir +END INTERFACE + +buf = ' ' +ierr_local = 0 +CALL c_readdir(dir, buf, ierr_local) +filename = TRIM(arr2str(buf)) +ierr = ierr_local +END PROCEDURE system_readdir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_rewinddir +INTERFACE + SUBROUTINE c_rewinddir(c_dir) BIND(c, name="rewinddir") + IMPORT C_CHAR, C_INT, C_PTR + TYPE(C_PTR), VALUE :: c_dir + END SUBROUTINE c_rewinddir +END INTERFACE + +CALL c_rewinddir(dir) +END PROCEDURE system_rewinddir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_closedir +INTEGER :: ierr_local + +INTERFACE + FUNCTION c_closedir(c_dir) BIND(c, name="closedir") RESULT(c_err) + IMPORT C_CHAR, C_INT, C_PTR + TYPE(C_PTR), VALUE :: c_dir + INTEGER(kind=C_INT) :: c_err + END FUNCTION c_closedir +END INTERFACE + +ierr_local = c_closedir(dir) +IF (PRESENT(ierr)) THEN + ierr = ierr_local +ELSE + IF (ierr_local /= 0) THEN + PRINT *, "*system_closedir* error", ierr_local + STOP 3 + END IF +END IF +END PROCEDURE system_closedir + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fileglob +CHARACTER(len=255) :: tmpfile +! scratch filename to hold expanded file list +CHARACTER(len=255) :: cmd +! string to build system command in +INTEGER :: iotmp +! needed to open unique scratch file for holding file list +INTEGER :: i, ios, icount +write(tmpfile,'(*(g0))')'/tmp/__filelist_',timestamp(),'_',system_getpid() +! preliminary scratch file name +cmd = 'ls -d '//TRIM(glob)//'>'//TRIM(tmpfile)//' ' +! build command string +CALL execute_command_line(cmd) +! Execute the command specified by the string. +OPEN (newunit=iotmp, file=tmpfile, iostat=ios) +! open unique scratch filename +IF (ios .NE. 0) RETURN +! the open failed +icount = 0 +! number of filenames in expanded list +DO +! count the number of lines (assumed ==files) so know what to allocate + READ (iotmp, '(a)', iostat=ios) + ! move down a line in the file to count number of lines + IF (ios .NE. 0) EXIT + ! hopefully, this is because end of file was encountered so done + icount = icount + 1 + ! increment line count +END DO +REWIND (iotmp) +! rewind file list so can read and store it +ALLOCATE (list(icount)) +! allocate and fill the array +DO i = 1, icount + READ (iotmp, '(a)') list(i) + ! read a filename from a line +END DO +CLOSE (iotmp, status='delete', iostat=ios) +! close and delete scratch file +END PROCEDURE fileglob + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_dir +CHARACTER(len=:), ALLOCATABLE :: wild +TYPE(C_PTR) :: dir +CHARACTER(len=:), ALLOCATABLE :: filename +INTEGER :: i, ierr, icount, longest +longest = 0 +icount = 0 +IF (PRESENT(pattern)) THEN + wild = pattern +ELSE + wild = '*' +END IF +IF (PRESENT(directory)) THEN !--- open directory stream to read from + CALL system_opendir(directory, dir, ierr) +ELSE + CALL system_opendir('.', dir, ierr) +END IF +IF (ierr .EQ. 0) THEN + DO i = 1, 2 !--- read directory stream twice, first time to get size + DO + CALL system_readdir(dir, filename, ierr) + IF (filename .EQ. ' ') EXIT + IF (wild .NE. '*') THEN + IF (.NOT. matchw(filename, wild)) CYCLE ! Call a wildcard matching routine. + END IF + icount = icount + 1 + SELECT CASE (i) + CASE (1) + longest = MAX(longest, LEN(filename)) + CASE (2) + system_dir(icount) = filename + END SELECT + END DO + IF (i .EQ. 1) THEN + CALL system_rewinddir(dir) + IF (ALLOCATED(system_dir)) DEALLOCATE (system_dir) + ALLOCATE (CHARACTER(len=longest) :: system_dir(icount)) + icount = 0 + END IF + END DO +END IF +CALL system_closedir(dir, ierr) !--- close directory stream +END PROCEDURE system_dir + +!---------------------------------------------------------------------------- +! Include Error +!---------------------------------------------------------------------------- +END SUBMODULE FileMethods diff --git a/src/submodules/System/src/System_Method@GetMethods.F90 b/src/submodules/System/src/System_Method@GetMethods.F90 index c20e3929c..27244ce72 100644 --- a/src/submodules/System/src/System_Method@GetMethods.F90 +++ b/src/submodules/System/src/System_Method@GetMethods.F90 @@ -14,15 +14,289 @@ ! ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -! SUBMODULE(System_Method) GetMethods -IMPLICIT NONE +USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT +IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! system_cpu_time +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_cpu_time +REAL(kind=C_FLOAT) :: c_user, c_system, c_total +INTERFACE + SUBROUTINE c_cpu_time(c_total, c_user, c_system) BIND(C, NAME='my_cpu_time') + IMPORT :: C_FLOAT + REAL(kind=C_FLOAT) :: c_total, c_user, c_system + END SUBROUTINE c_cpu_time +END INTERFACE + +CALL c_cpu_time(c_total, c_user, c_system) +user = c_user +system = c_system +total = c_total +END PROCEDURE system_cpu_time + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_link +INTEGER(kind=C_INT) :: c_ierr + +INTERFACE + FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_link +END INTERFACE + +c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) +ierr = c_ierr +END PROCEDURE system_link + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_unlink +INTERFACE + FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_unlink +END INTERFACE +ierr = c_unlink(str2_carr(TRIM(fname))) +END PROCEDURE system_unlink + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_setumask +INTEGER(kind=C_INT) :: umask_c +umask_c = umask_value +old_umask = system_umask(umask_c) ! set current umask +END PROCEDURE system_setumask + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getumask +INTEGER :: idum +INTEGER(kind=C_INT) :: old_umask + +old_umask = system_umask(0_C_INT) +! get current umask but by setting umask to 0 +! (a conservative mask so no vulnerability is open) +idum = system_umask(old_umask) +! set back to original mask +umask_value = old_umask +END PROCEDURE system_getumask + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_perror +INTEGER :: ios + +INTERFACE + SUBROUTINE c_perror(c_prefix) BIND(C, name="perror") + IMPORT C_CHAR + CHARACTER(kind=C_CHAR) :: c_prefix(*) + END SUBROUTINE c_perror +END INTERFACE + +FLUSH (unit=ERROR_UNIT, iostat=ios) +FLUSH (unit=OUTPUT_UNIT, iostat=ios) +FLUSH (unit=INPUT_UNIT, iostat=ios) +CALL c_perror(str2_carr((TRIM(prefix)))) +CALL c_flush() +END PROCEDURE system_perror + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_uname +! describe the C routine to Fortran +! void system_uname(char *which, char *buf, int *buflen); +INTERFACE + SUBROUTINE system_uname_c(WHICH, BUF, BUFLEN) BIND(C, NAME='my_uname') + IMPORT C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH + CHARACTER(KIND=C_CHAR), INTENT(out) :: BUF(*) + INTEGER(kind=C_INT), INTENT(in) :: BUFLEN + END SUBROUTINE system_uname_c +END INTERFACE + +NAMEOUT = 'unknown' +CALL system_uname_c(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) +END PROCEDURE system_uname + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +MODULE PROCEDURE system_gethostname +CHARACTER(kind=C_CHAR, len=1) :: C_BUFF(HOST_NAME_MAX + 1) + +! describe the C routine to Fortran +!int gethostname(char *name, size_t namelen); +INTERFACE + FUNCTION system_gethostname_c(c_buf, c_buflen) BIND(C, NAME='gethostname') + IMPORT C_CHAR, C_INT + IMPLICIT NONE + INTEGER(kind=C_INT) :: system_gethostname_c + CHARACTER(KIND=C_CHAR), INTENT(out) :: c_buf(*) + INTEGER(kind=C_INT), INTENT(in), VALUE :: c_buflen + END FUNCTION system_gethostname_c +END INTERFACE + +C_BUFF = ' ' +ierr = system_gethostname_c(C_BUFF, HOST_NAME_MAX) ! Host names are limited to {HOST_NAME_MAX} bytes. +NAME = TRIM(arr2str(C_BUFF)) +END PROCEDURE system_gethostname + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getlogin +TYPE(C_PTR) :: username + +INTERFACE + FUNCTION c_getlogin() BIND(c, name="getlogin") RESULT(c_username) + IMPORT C_INT, C_PTR + TYPE(C_PTR) :: c_username + END FUNCTION c_getlogin +END INTERFACE + +username = c_getlogin() +IF (.NOT. C_ASSOCIATED(username)) THEN + ! In windows 10 subsystem running Ubunto does not work + !write(*,'(a)')'*system_getlogin* Error getting username. not associated' + !fname=c_null_char + fname = system_getpwuid(system_geteuid()) +ELSE + fname = c2f_string(username) +END IF +END PROCEDURE system_getlogin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_perm +TYPE(C_PTR) :: permissions +INTEGER(kind=C_LONG) :: mode_local + +INTERFACE + FUNCTION c_perm(c_mode) BIND(c, name="my_get_perm") RESULT(c_permissions) + IMPORT C_INT, C_PTR, C_LONG + INTEGER(kind=C_LONG), VALUE :: c_mode + TYPE(C_PTR) :: c_permissions + END FUNCTION c_perm +END INTERFACE + +mode_local = INT(anyinteger_to_64bit(mode), kind=C_LONG) +permissions = c_perm(mode_local) +IF (.NOT. C_ASSOCIATED(permissions)) THEN + WRITE (*, '(a)') '*system_perm* Error getting permissions. not associated' + perms = C_NULL_CHAR +ELSE + perms = c2f_string(permissions) +END IF +END PROCEDURE system_perm + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getgrgid +CHARACTER(kind=C_CHAR, len=1) :: groupname(4097) +! assumed long enough for any groupname +INTEGER :: ierr +INTEGER(kind=C_LONG_LONG) :: gid_local + +INTERFACE + function c_getgrgid(c_gid,c_groupname) bind(c,name="my_getgrgid") result(c_ierr) + IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG + INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_gid + CHARACTER(kind=C_CHAR), INTENT(out) :: c_groupname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_getgrgid +END INTERFACE + +gid_local = anyinteger_to_64bit(gid) +ierr = c_getgrgid(gid_local, groupname) +IF (ierr .EQ. 0) THEN + gname = TRIM(arr2str(groupname)) +ELSE + gname = '' +END IF +END PROCEDURE system_getgrgid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getpwuid +CHARACTER(kind=C_CHAR, len=1) :: username(4097) +! assumed long enough for any username +INTEGER :: ierr +INTEGER(kind=C_LONG_LONG) :: uid_local + +INTERFACE + function c_getpwuid(c_uid,c_username) bind(c,name="my_getpwuid") result(c_ierr) + IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG + INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_uid + CHARACTER(kind=C_CHAR), INTENT(out) :: c_username(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_getpwuid +END INTERFACE + +uid_local = anyinteger_to_64bit(uid) +ierr = c_getpwuid(uid_local, username) +IF (ierr .EQ. 0) THEN + uname = TRIM(arr2str(username)) +ELSE + uname = '' +END IF +END PROCEDURE system_getpwuid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_stat +INTEGER(kind=C_LONG) :: cvalues(13) +INTEGER(kind=C_INT) :: cierr + +INTERFACE + SUBROUTINE c_stat(buffer, cvalues, cierr, cdebug) BIND(c, name="my_stat") + IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT, C_LONG + CHARACTER(kind=C_CHAR), INTENT(in) :: buffer(*) + INTEGER(kind=C_LONG), INTENT(out) :: cvalues(*) + INTEGER(kind=C_INT) :: cierr + INTEGER(kind=C_INT), INTENT(in) :: cdebug + END SUBROUTINE c_stat +END INTERFACE + +CALL c_stat(str2_carr(TRIM(pathname)), cvalues, cierr, 0_C_INT) +values = cvalues +IF (PRESENT(ierr)) THEN + ierr = cierr +END IF +END PROCEDURE system_stat + END SUBMODULE GetMethods diff --git a/src/submodules/System/src/System_Method@SetMethods.F90 b/src/submodules/System/src/System_Method@SetMethods.F90 deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/submodules/System/src/System_Method@SignalMethods.F90 b/src/submodules/System/src/System_Method@SignalMethods.F90 new file mode 100644 index 000000000..3fb9e8b66 --- /dev/null +++ b/src/submodules/System/src/System_Method@SignalMethods.F90 @@ -0,0 +1,39 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(System_Method) SignalMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! System_Signal +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Signal +TYPE(C_FUNPTR) :: ret, c_handler + +IF (PRESENT(handler_routine)) THEN + handler_ptr_array(signum)%sub => handler_routine +ELSE + handler_ptr_array(signum)%sub => NULL() +END IF + +c_handler = C_FUNLOC(f_handler) +ret = C_Signal(signum, c_handler) +END PROCEDURE System_Signal + +END SUBMODULE SignalMethods diff --git a/src/submodules/System/src/System_Method@UtilityMethods.F90 b/src/submodules/System/src/System_Method@UtilityMethods.F90 new file mode 100644 index 000000000..3f8cf26ce --- /dev/null +++ b/src/submodules/System/src/System_Method@UtilityMethods.F90 @@ -0,0 +1,219 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(System_Method) UtilityMethods +USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! C2F_String +!---------------------------------------------------------------------------- + +MODULE PROCEDURE C2F_string +CHARACTER(kind=C_CHAR), DIMENSION(:), POINTER :: & + char_array_pointer => NULL() +INTEGER, PARAMETER :: max_len = 4096 +CHARACTER(len=max_len) :: aux_string +INTEGER :: i +INTEGER :: length + +length = 0 +CALL C_F_POINTER(c_string_pointer, char_array_pointer, [max_len]) + +IF (.NOT. ASSOCIATED(char_array_pointer)) THEN + IF (ALLOCATED(f_string)) DEALLOCATE (f_string) + ALLOCATE (CHARACTER(len=4) :: f_string) + f_string = C_NULL_CHAR + RETURN +END IF + +aux_string = " " + +DO i = 1, max_len + IF (char_array_pointer(i) == C_NULL_CHAR) THEN + length = i - 1; EXIT + END IF + aux_string(i:i) = char_array_pointer(i) +END DO + +IF (ALLOCATED(f_string)) DEALLOCATE (f_string) +ALLOCATE (CHARACTER(len=length) :: f_string) +f_string = aux_string(1:length) +END PROCEDURE C2F_String + +!---------------------------------------------------------------------------- +! Str2_Carr +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Str2_Carr +INTEGER :: i +DO i = 1, LEN_TRIM(string) + array(i) = string(i:i) +END DO +array(i:i) = C_NULL_CHAR +END PROCEDURE Str2_Carr + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE timestamp +epoch = C_Time(INT(0, kind=8)) +END PROCEDURE timestamp + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE arr2str +INTEGER :: i + +string = ' ' +DO i = 1, SIZE(array) + IF (array(i) .EQ. CHAR(0)) THEN + EXIT + ELSE + string(i:i) = array(i) + END IF +END DO +END PROCEDURE arr2str + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matchw +CHARACTER(len=LEN(tame) + 1) :: tametext +CHARACTER(len=LEN(wild) + 1) :: wildtext +CHARACTER(len=1), PARAMETER :: NULL = CHAR(0) +INTEGER :: wlen, ti, wi, i +CHARACTER(len=:), ALLOCATABLE :: tbookmark, wbookmark + +! These two values are set when we observe a wildcard character. They +! represent the locations, in the two strings, from which we start once we've observed it. +tametext = tame//NULL +wildtext = wild//NULL +tbookmark = NULL +wbookmark = NULL +wlen = LEN(wild) +wi = 1 +ti = 1 +DO ! Walk the text strings one character at a time. + IF (wildtext(wi:wi) == '*') THEN ! How do you match a unique text string? + DO i = wi, wlen ! Easy: unique up on it! + IF (wildtext(wi:wi) .EQ. '*') THEN + wi = wi + 1 + ELSE + EXIT + END IF + END DO + IF (wildtext(wi:wi) .EQ. NULL) THEN ! "x" matches "*" + matchw = .TRUE. + RETURN + END IF + IF (wildtext(wi:wi) .NE. '?') THEN + ! Fast-forward to next possible match. + DO WHILE (tametext(ti:ti) .NE. wildtext(wi:wi)) + ti = ti + 1 + IF (tametext(ti:ti) .EQ. NULL) THEN + matchw = .FALSE. + RETURN ! "x" doesn't match "*y*" + END IF + END DO + END IF + wbookmark = wildtext(wi:) + tbookmark = tametext(ti:) + elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then + ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + IF (wbookmark .NE. NULL) THEN + IF (wildtext(wi:) .NE. wbookmark) THEN + wildtext = wbookmark; + wlen = LEN_TRIM(wbookmark) + wi = 1 + ! Don't go this far back again. + IF (tametext(ti:ti) .NE. wildtext(wi:wi)) THEN + tbookmark = tbookmark(2:) + tametext = tbookmark + ti = 1 + CYCLE ! "xy" matches "*y" + ELSE + wi = wi + 1 + END IF + END IF + IF (tametext(ti:ti) .NE. NULL) THEN + ti = ti + 1 + CYCLE ! "mississippi" matches "*sip*" + END IF + END IF + matchw = .FALSE. + RETURN ! "xy" doesn't match "x" + END IF + ti = ti + 1 + wi = wi + 1 + IF (tametext(ti:ti) .EQ. NULL) THEN ! How do you match a tame text string? + IF (wildtext(wi:wi) .NE. NULL) THEN + DO WHILE (wildtext(wi:wi) == '*') ! The tame way: unique up on it! + wi = wi + 1 ! "x" matches "x*" + IF (wildtext(wi:wi) .EQ. NULL) EXIT + END DO + END IF + IF (wildtext(wi:wi) .EQ. NULL) THEN + matchw = .TRUE. + RETURN ! "x" matches "x" + END IF + matchw = .FALSE. + RETURN ! "x" doesn't match "xy" + END IF +END DO +END PROCEDURE matchw + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE anyinteger_to_64bit +SELECT TYPE (intin) +TYPE is (INTEGER(kind=INT8)); ii38 = INT(intin, kind=INT64) +TYPE is (INTEGER(kind=INT16)); ii38 = INT(intin, kind=INT64) +TYPE is (INTEGER(kind=INT32)); ii38 = intin +TYPE is (INTEGER(kind=INT64)); ii38 = intin + !class default + !write(error_unit,*)'ERROR: unknown integer type' + !stop 'ERROR: *anyinteger_to_64* unknown integer type' +END SELECT +END PROCEDURE anyinteger_to_64bit + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE f_handler +LOGICAL :: isok + +isok = ASSOCIATED(handler_ptr_array(signum)%sub) +IF (isok) THEN + CALL handler_ptr_array(signum)%sub(signum) +END IF +END PROCEDURE f_handler + +!---------------------------------------------------------------------------- +! Include Error +!---------------------------------------------------------------------------- + +END SUBMODULE UtilityMethods From ae64e053d41a923d06279f358ac4b2fb0e551f04 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 7 Feb 2026 08:43:56 +0900 Subject: [PATCH 4/6] Display_Method: updating equalline method --- src/modules/Display/src/Display_Method.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/modules/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90 index 7db090a23..81a8dc642 100755 --- a/src/modules/Display/src/Display_Method.F90 +++ b/src/modules/Display/src/Display_Method.F90 @@ -1642,9 +1642,9 @@ SUBROUTINE EqualLine(unitNo) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo IF (PRESENT(unitNo)) THEN - WRITE (unitNo, "(A)") equal + WRITE (unitNo, '(80("="))') ELSE - WRITE (stdout, "(A)") equal + WRITE (stdout, '(80("="))') END IF END SUBROUTINE EqualLine From e18796877deae902f703df7c32074eecfbc7f09c Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sat, 7 Feb 2026 08:44:31 +0900 Subject: [PATCH 5/6] System_Method: updating system method structure --- src/modules/System/src/System_Method.F90 | 3639 ++++++----------- .../src/System_Method@EnquiryMethods.F90 | 3 + .../src/System_Method@EnviormentMethods.F90 | 180 - .../src/System_Method@EnvironmentMethods.F90 | 132 + .../System/src/System_Method@FileMethods.F90 | 47 + .../System/src/System_Method@GetMethods.F90 | 48 +- .../src/System_Method@SignalMethods.F90 | 2 + .../src/System_Method@UtilityMethods.F90 | 90 +- 8 files changed, 1464 insertions(+), 2677 deletions(-) delete mode 100644 src/submodules/System/src/System_Method@EnviormentMethods.F90 diff --git a/src/modules/System/src/System_Method.F90 b/src/modules/System/src/System_Method.F90 index 2c4d44d64..77c763827 100755 --- a/src/modules/System/src/System_Method.F90 +++ b/src/modules/System/src/System_Method.F90 @@ -174,7 +174,8 @@ MODULE System_Method USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER, C_NULL_CHAR, C_NULL_PTR -USE, INTRINSIC :: ISO_C_BINDING +USE ISO_C_BINDING, ONLY: C_LONG, C_SHORT, C_FUNPTR + USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT8, INT16, INT32, INT64 !!, real32, real64, real128, dp=>real128 USE SystemInterface @@ -388,7 +389,7 @@ END SUBROUTINE handler TYPE(handler_pointer), DIMENSION(no_of_signals) :: handler_ptr_array !---------------------------------------------------------------------------- -! system_signal +! System_Signal@SignalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -411,43 +412,11 @@ END SUBROUTINE handler ! Note that the signals SIGKILL and SIGSTOP cannot be handled ! this way. ! -! -!## Usage +!## Examples ! !```fortran -! program demo_system_signal -! use M_system, only : system_signal -! implicit none -! logical :: loop=.true. -! integer, parameter :: SIGINT=2,SIGQUIT=3 -! call system_signal(SIGINT,exitloop) -! call system_signal(SIGQUIT,quit) -! write(*,*)'Starting infinite loop. Press Ctrl+C to exit.' -! do while(loop) -! enddo -! write(*,*)'Reporting from outside the infinite loop.' -! write(*,*)'Starting another loop. Do Ctrl+\ anytime to quit.' -! loop=.true. -! call system_signal(2) -! write(*,*)'Just installed do-nothing handler for SIGINT. Try Ctrl+C to test.' -! do while(loop) -! enddo -! write(*,*)'You should never see this line when running this demo.' -! -! contains -! -! subroutine exitloop(signum) -! integer :: signum -! write(*,*)'Caught SIGINT. Exiting infinite loop.' -! loop=.false. -! end subroutine exitloop -! -! subroutine quit(signum) -! integer :: signum -! STOP 'Caught SIGQUIT. Stopping demo.' -! end subroutine quit -! end program demo_system_signal -! ``` +! {{% fortran-code file="examples/System_Signal_test_1.F90" %}} +!``` INTERFACE MODULE SUBROUTINE System_Signal(signum, handler_routine) @@ -458,7 +427,7 @@ END SUBROUTINE System_Signal END INTERFACE !---------------------------------------------------------------------------- -! System_Access +! System_Access@EnquiryMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -467,65 +436,36 @@ END SUBROUTINE System_Signal ! !# System_Access ! +! The system_access(3f) function checks pathname existence and access +! permissions. The function checks the pathname for accessibility +! according to the bit pattern contained in amode, using the real user +! ID in place of the effective user ID and the real group ID in place +! of the effective group ID. ! -!The system_access(3f) function checks pathname existence and access -!permissions. The function checks the pathname for accessibility -!according to the bit pattern contained in amode, using the real user -!ID in place of the effective user ID and the real group ID in place -!of the effective group ID. -! -!The value of amode is either the bitwise-inclusive OR of the access -!permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). -! -!- pathname: a character string representing a directory pathname. -! Trailing spaces are ignored. -!- amode: bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. -!- Return value: If not true an error occurred or -! the requested access is not granted -! +! The value of amode is either the bitwise-inclusive OR of the access +! permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). ! !## Examples ! -! Check if filename is accessible -! !```fortran -! program demo_system_access -! use M_system, only : system_access, F_OK, R_OK, W_OK, X_OK -! implicit none -! integer :: i -! character(len=80),parameter :: names(*)=[ & -! '/usr/bin/bash ', & -! '/tmp/NOTTHERE ', & -! '/usr/local ', & -! '. ', & -! 'PROBABLY_NOT '] -! do i=1,size(names) -! write(*,*)' does ',trim(names(i)),' exist? ', & -! system_access(names(i),F_OK) -! -! write(*,*)' is ',trim(names(i)),' readable? ', & -! system_access(names(i),R_OK) -! -! write(*,*)' is ',trim(names(i)),' writable? ', & -! system_access(names(i),W_OK) -! -! write(*,*)' is ',trim(names(i)),' executable? ', & -! system_access(names(i),X_OK) -! -! enddo -! end program demo_system_access +! {{% fortran-code file="examples/System_Access_test_1.F90" %}} !``` INTERFACE MODULE ELEMENTAL IMPURE FUNCTION System_Access(pathname, amode) CHARACTER(len=*), INTENT(IN) :: pathname + !! a character string representing a directory pathname. + !! Trailing spaces are ignored. INTEGER, INTENT(IN) :: amode + !! bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. LOGICAL :: System_Access + !! Return value: If not true an error occurred or + !! the requested access is not granted END FUNCTION System_Access END INTERFACE !---------------------------------------------------------------------------- -! System_Utime +! System_Utime@FileMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -544,24 +484,6 @@ END FUNCTION System_Access ! match the owner of the file, or the process has to have write ! permission to the file or have appropriate privileges, ! -!## Arguments -! -!### times -! -!If present, the values will be interpreted as the access -!and modification times as Unix Epoch values. That is, -!they are times measured in seconds since the Unix Epoch. -! -!### pathname -! -!name of the file whose access and modification times are to be updated. -! -!## Return values -! -!Upon successful completion .TRUE. is returned. Otherwise, -!.FALSE. is returned and errno shall be set to indicate the error, -!and the file times remain unaffected. -! !## Errors ! !The underlying utime(3c) function fails if: @@ -584,7 +506,6 @@ END FUNCTION System_Access ! ! The length of a component of a pathname is longer than {NAME_MAX}. ! -! !### ENOENT ! ! A component of path does not name an existing file or path is an @@ -623,169 +544,78 @@ END FUNCTION System_Access ! an intermediate result with a length that exceeds ! {PATH_MAX}. ! -! -!## Usage +!## Examples ! !```fortran -! program demo_system_utime -! use M_system, only : system_utime, system_perror -! implicit none -! character(len=4096) :: pathname -! integer :: times(2) -! integer :: i -! do i=1,command_argument_count() -! call get_command_argument(i, pathname) -! if(.not.system_utime(pathname,times))then -! call system_perror('*demo_system_utime*') -! endif -! enddo -! end program demo_system_utime +! {{% fortran-code file="examples/System_Utime_test_1.F90" %}} !``` INTERFACE - MODULE FUNCTION system_utime(pathname, times) + MODULE FUNCTION System_Utime(pathname, times) CHARACTER(len=*), INTENT(in) :: pathname + !!name of the file whose access and modification times are to be updated. INTEGER, INTENT(in), OPTIONAL :: times(2) - LOGICAL :: system_utime + !! If present, the values will be interpreted as the access + !! and modification times as Unix Epoch values. That is, + !! they are times measured in seconds since the Unix Epoch. + LOGICAL :: System_Utime + !! Upon successful completion .TRUE. is returned. Otherwise, + !! .FALSE. is returned and errno shall be set to indicate the error, + !! and the file times remain unaffected. END FUNCTION System_Utime END INTERFACE !---------------------------------------------------------------------------- -! +! System_RealPath@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_realpath(3f) - [M_system:FILE_SYSTEM] call realpath(3c) to resolve a pathname -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_realpath(input) result(output) -!! -!! character(len=*),intent(in) :: input -!! character(len=:),allocatable :: output -!!##DESCRIPTION -!! system_realpath(3f) calls the C routine realpath(3c) to obtain the absolute pathname of given path -!!##OPTIONS -!! -!! INPUT pathname to resolve -!! -!!##RETURN VALUE -!! OUTPUT The absolute pathname of the given input pathname. -!! The pathname shall contain no components that are dot -!! or dot-dot, or are symbolic links. It is equal to the -!! NULL character if an error occurred. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_realpath -!! use M_system, only : system_realpath, system_perror -!! implicit none -!! ! resolve each pathname given on command line -!! character(len=:),allocatable :: pathi,patho -!! integer :: i -!! integer :: filename_length -!! do i = 1, command_argument_count() -!! ! get pathname from command line arguments -!! call get_command_argument (i , length=filename_length) -!! if(allocated(pathi))deallocate(pathi) -!! allocate(character(len=filename_length) :: pathi) -!! call get_command_argument (i , value=pathi) -!! ! -!! ! resolve each pathname -!! patho=system_realpath(pathi) -!! if(patho.ne.char(0))then -!! write(*,*)trim(pathi),'=>',trim(patho) -!! else -!! call system_perror('*system_realpath* error for pathname '//trim(pathi)//':') -!! write(*,*)trim(pathi),'=>',trim(patho) -!! endif -!! deallocate(pathi) -!! enddo -!! ! if there were no pathnames given resolve the pathname "." -!! if(i.eq.1)then -!! patho=system_realpath('.') -!! write(*,*)'.=>',trim(patho) -!! endif -!! end program demo_system_realpath -!! -!! Example usage: -!! -!! demo_system_realpath -!! .=>/home/urbanjs/V600 -!! -!! cd /usr/share/man -!! demo_system_realpath . .. NotThere -!! .=>/usr/share/man -!! ..=>/usr/share -!! *system_realpath* error for pathname NotThere:: No such file or directory -!! NotThere=>NotThere +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Resolve the relative path +! +!# System_Realpath +! +! system_realpath(3f) calls the C routine realpath(3c) to obtain +! the absolute pathname of given path +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Realpath_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_realpath(input) RESULT(string) - CHARACTER(len=*), INTENT(in) :: input - CHARACTER(len=:), ALLOCATABLE :: string - END FUNCTION system_realpath + MODULE FUNCTION System_Realpath(input) RESULT(string) + CHARACTER(*), INTENT(in) :: input + !! pathname to resolve + CHARACTER(:), ALLOCATABLE :: string + !! The absolute pathname of the given input pathname. + !! The pathname shall contain no components that are dot + !! or dot-dot, or are symbolic links. It is equal to the + !! NULL character if an error occurred. + END FUNCTION System_Realpath END INTERFACE !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_issock(3f) - [M_system:QUERY_FILE] checks if argument is a socket -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_issock(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_issock -!! -!!##DESCRIPTION -!! The issock(3f) function checks if path is a path to a socket -!! -!!##OPTIONS -!! path a character string representing a socket pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_issock() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a socket -!! -!! program demo_system_issock -!! use M_system, only : system_issock -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'sock.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a socket? ', system_issock(names(i)) -!! enddo -!! end program demo_system_issock +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a socket +! +!# System_Issock +! +! The issock(3f) function checks if path is a path to a socket INTERFACE MODULE FUNCTION System_Issock(pathname) - CHARACTER(len=*), INTENT(in) :: pathname + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a socket pathname. + !! Trailing spaces are ignored. LOGICAL :: System_Issock + !! The system_issock() function should always be successful and no + !! return value is reserved to indicate an error. END FUNCTION System_Issock END INTERFACE @@ -799,8 +629,8 @@ END FUNCTION System_Issock INTERFACE MODULE FUNCTION C2F_String(c_string_pointer) RESULT(f_string) - TYPE(C_PTR), INTENT(in) :: c_string_pointer - CHARACTER(len=:), ALLOCATABLE :: f_string + TYPE(C_PTR), INTENT(IN) :: c_string_pointer + CHARACTER(:), ALLOCATABLE :: f_string END FUNCTION C2F_String END INTERFACE @@ -814,13 +644,13 @@ END FUNCTION C2F_String INTERFACE MODULE PURE FUNCTION str2_carr(string) RESULT(array) - CHARACTER(len=*), INTENT(in) :: string + CHARACTER(*), INTENT(in) :: string CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) END FUNCTION str2_carr END INTERFACE !---------------------------------------------------------------------------- -! TimeStamp +! TimeStamp@UtilityMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -834,482 +664,217 @@ END FUNCTION TimeStamp END INTERFACE !---------------------------------------------------------------------------- -! +! System_Isfifo@EnquiryMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_isfifo(3f) - [M_system:QUERY_FILE] checks if argument is a fifo - named pipe -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isfifo(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isfifo -!! -!!##DESCRIPTION -!! The isfifo(3f) function checks if path is a path to a fifo - named pipe. -!! -!!##OPTIONS -!! path a character string representing a fifo - named pipe pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isfifo() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a FIFO file -!! -!! program demo_system_isfifo -!! use M_system, only : system_isfifo -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'fifo.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a fifo(named pipe)? ', system_isfifo(names(i)) -!! enddo -!! end program demo_system_isfifo +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: check if argument is a fifo named pipe +! +!# System_Isfifo +! +! Check if argument is a fifo named pipe. INTERFACE MODULE ELEMENTAL IMPURE FUNCTION System_Isfifo(pathname) CHARACTER(len=*), INTENT(in) :: pathname + !! a character string representing a fifo - named pipe pathname. + !! Trailing spaces are ignored. LOGICAL :: System_Isfifo + !! The system_isfifo() function should always be successful and no + !! return value is reserved to indicate an error. END FUNCTION System_Isfifo END INTERFACE !---------------------------------------------------------------------------- -! +! System_Ischr@EnquiryMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_ischr(3f) - [M_system:QUERY_FILE] checks if argument is a character device -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_ischr(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_ischr -!! -!!##DESCRIPTION -!! The ischr(3f) function checks if path is a path to a character device. -!! -!!##OPTIONS -!! path a character string representing a character device pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_ischr() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a character file -!! -!! program demo_system_ischr -!! use M_system, only : system_ischr -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'char_dev.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a character device? ', system_ischr(names(i)) -!! enddo -!! end program demo_system_ischr -!! -!! Results: +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a character device +! +!# System_Ischr +! +! The ischr(3f) function checks if path is a path to a character device. INTERFACE - MODULE ELEMENTAL impure FUNCTION System_Ischr(pathname) - CHARACTER(len=*), INTENT(in) :: pathname + MODULE ELEMENTAL IMPURE FUNCTION System_Ischr(pathname) + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a character device pathname. + !! Trailing spaces are ignored. LOGICAL :: System_Ischr + !! The system_ischr() function should always be successful and no + !! return value is reserved to indicate an error. END FUNCTION System_Ischr END INTERFACE !---------------------------------------------------------------------------- -! +! System_Isreg@EnquiryMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_isreg(3f) - [M_system:QUERY_FILE] checks if argument is a regular file -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isreg(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isreg -!! -!!##DESCRIPTION -!! The isreg(3f) function checks if path is a regular file -!! -!!##OPTIONS -!! path a character string representing a pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isreg() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_islnk(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a regular file -!! -!! program simple -!! use M_system, only : system_isreg -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! 'test.txt ', & -!! '~/.bashrc ', & -!! '.bashrc ', & -!! '. '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a regular file? ', system_isreg(names(i)) -!! enddo -!! end program simple -!! -!! EXTENDED EXAMPLE -!! list readable non-hidden regular files and links in current directory -!! -!! program demo_system_isreg -!! use M_system, only : isreg=>system_isreg, islnk=>system_islnk -!! use M_system, only : access=>system_access, R_OK -!! use M_system, only : system_dir -!! implicit none -!! character(len=1024),allocatable :: filenames(:) ! BUG: cannot use len=: in gfortran 8.3.1 -!! logical,allocatable :: mymask(:) -!! integer :: i -!! ! list readable non-hidden regular files and links in current directory -!! filenames=system_dir(pattern='*') ! make list of all files in current directory -!! mymask= isreg(filenames).or.islnk(filenames) ! select regular files and links -!! where(mymask) mymask=filenames(:)(1:1).ne.'.' ! skip hidden directories in those -!! where(mymask) mymask=access(filenames,R_OK) ! select readable files in those -!! filenames=pack(filenames,mask=mymask) -!! write(*,'(a)')(trim(filenames(i)),i=1,size(filenames)) -!! end program demo_system_isreg +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a regular file +! +!# System_Isreg +! +! The isreg(3f) function checks if path is a regular file +! +!## Examples 1 +! +!```fortran +! {{% fortran-code file="examples/System_Isreg_test_1.F90" %}} +!``` +! +!## Examples 2 +! +!```fortran +! {{% fortran-code file="examples/System_Isreg_test_2.F90" %}} +!``` INTERFACE - MODULE ELEMENTAL impure FUNCTION system_isreg(pathname) - CHARACTER(len=*), INTENT(in) :: pathname - LOGICAL :: system_isreg - END FUNCTION system_isreg + MODULE ELEMENTAL impure FUNCTION System_Isreg(pathname) + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Isreg + !! The system_isreg() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Isreg END INTERFACE !---------------------------------------------------------------------------- -! +! System_Islnk@EnquiryMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_islnk(3f) - [M_system:QUERY_FILE] checks if argument is a link -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_islnk(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_islnk -!! -!!##DESCRIPTION -!! The islnk(3f) function checks if path is a path to a link. -!! -!!##OPTIONS -!! path a character string representing a link -!! pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! system_islnk The system_islnk() function should always be -!! successful and no return value is reserved to -!! indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! -!! Sample program: -!! -!! program demo_system_islnk -!! use M_system, only : system_islnk -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'link.test ', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a link? ', system_islnk(names(i)) -!! enddo -!! end program demo_system_islnk -!! -!! Results: +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a link +! +!# System_Islnk +! +! The islnk(3f) function checks if path is a path to a link. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Islink_test_1.F90" %}} +!``` INTERFACE - MODULE ELEMENTAL impure FUNCTION System_Islnk(pathname) + MODULE ELEMENTAL IMPURE FUNCTION System_Islnk(pathname) CHARACTER(len=*), INTENT(in) :: pathname + !! a character string representing a link + !! pathname. Trailing spaces are ignored. LOGICAL :: System_Islnk + !! The system_islnk() function should always be + !! successful and no return value is reserved to + !! indicate an error. END FUNCTION System_Islnk END INTERFACE !---------------------------------------------------------------------------- -! +! System_Isblk@EnquiryMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_isblk(3f) - [M_system:QUERY_FILE] checks if argument is a block device -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isblk(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isblk -!! -!!##DESCRIPTION -!! The isblk(3f) function checks if path is a path to a block device. -!! -!!##OPTIONS -!! path a character string representing a block device pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isblk() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_isreg(3f), system_stat(3f), system_isdir(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! check if filename is a block device -!! -!! program demo_system_isblk -!! use M_system, only : system_isblk -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! '/tmp ', & -!! '/tmp/NOTTHERE ', & -!! '/usr/local ', & -!! '. ', & -!! 'block_device.tst', & -!! 'PROBABLY_NOT '] -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a block device? ', system_isblk(names(i)) -!! enddo -!! end program demo_system_isblk -!! -!! Results: + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Check if argument is a block device +! +!# System_Isblk +! +! The isblk(3f) function checks if path is a path to a block device. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Isblk_test_1.F90" %}} +!``` INTERFACE MODULE ELEMENTAL IMPURE FUNCTION System_Isblk(pathname) - CHARACTER(len=*), INTENT(IN) :: pathname + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a block device pathname. + !! Trailing spaces are ignored. LOGICAL :: System_Isblk + !! The system_isblk() function should always be successful and no + !! return value is reserved to indicate an error. END FUNCTION System_Isblk END INTERFACE !---------------------------------------------------------------------------- -! +! System_Isdir@EnquiryMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_isdir(3f) - [M_system:QUERY_FILE] checks if argument is a directory path -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_isdir(pathname) -!! -!! character(len=*),intent(in) :: pathname -!! logical :: system_isdir -!! -!!##DESCRIPTION -!! The system_isdir(3f) function checks if path is a directory. -!! -!!##OPTIONS -!! path a character string representing a directory pathname. Trailing spaces are ignored. -!! -!!##RETURN VALUE -!! The system_isdir() function should always be successful and no -!! return value is reserved to indicate an error. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##SEE ALSO -!! system_islnk(3f), system_stat(3f), isreg(3f), system_perm(3f) -!! -!!##EXAMPLE -!! -!! -!! Sample program -!! -!! program demo_system_isdir -!! use M_system, only : system_isdir -!! use M_system, only : access=>system_access, R_OK -!! use M_system, only : system_dir -!! implicit none -!! character(len=1024),allocatable :: filenames(:) ! BUG: cannot use len=: in gfortran 8.3.1 -!! integer :: i -!! character(len=80),parameter :: names(*)=[ & -!! & '/tmp ', & -!! & '/tmp/NOTTHERE ', & -!! & '/usr/local ', & -!! & '. ', & -!! & 'PROBABLY_NOT '] -!! ! -!! do i=1,size(names) -!! write(*,*)' is ',trim(names(i)),' a directory? ', system_isdir(names(i)) -!! enddo -!! ! -!! ! EXTENDED EXAMPLE: list readable non-hidden directories in current directory -!! filenames=system_dir(pattern='*') ! list all files in current directory -!! ! select readable directories -!! filenames=pack(filenames,system_isdir(filenames).and.access(filenames,R_OK)) -!! filenames=pack(filenames,filenames(:)(1:1) .ne.'.') ! skip hidden directories -!! do i=1,size(filenames) -!! write(*,*)' ',trim(filenames(i)),' is a directory' -!! enddo -!! ! -!! end program demo_system_isdir -!! -!! -!! Results: -!! -!! is /tmp a directory? T -!! is /tmp/NOTTHERE a directory? F -!! is /usr/local a directory? T -!! is . a directory? T -!! is PROBABLY_NOT a directory? F -!! -!! TEST is a directory -!! EXAMPLE is a directory +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a directory of not +! +!# System_Isdir +! +! The system_isdir(3f) function checks if path is a directory. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Isdir_test_1.F90" %}} +!``` INTERFACE MODULE ELEMENTAL IMPURE FUNCTION System_Isdir(dirname) CHARACTER(len=*), INTENT(in) :: dirname + !! a character string representing a directory pathname. + !! Trailing spaces are ignored. LOGICAL :: System_Isdir + !! The system_isdir() function should always be successful and no + !! return value is reserved to indicate an error. END FUNCTION System_Isdir END INTERFACE !---------------------------------------------------------------------------- -! +! System_Chown@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_chown(3f) - [M_system:FILE_SYSTEM] change file owner and group -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure logical function system_chown(path,owner,group) -!! -!! character(len=*),intent(in) :: path -!! integer,intent(in) :: owner -!! integer,intent(in) :: group -!! -!!##DESCRIPTION -!! The chown(3f) function changes owner and group of a file -!! -!! The path argument points to a pathname naming a file. The -!! user ID and group ID of the named file shall be set to the numeric -!! values contained in owner and group, respectively. -!! -!! Only processes with an effective user ID equal to the user ID of -!! the file or with appropriate privileges may change the ownership -!! of a file. -!! -!!##OPTIONS -!! path a character string representing a file pathname. -!! Trailing spaces are ignored. -!! owner UID of owner that ownership is to be changed to -!! group GID of group that ownership is to be changed to -!! -!!##RETURN VALUE -!! The system_chown(3f) function should return zero 0 if successful. -!! Otherwise, these functions shall return 1 and set errno to -!! indicate the error. If 1 is returned, no changes are made in -!! the user ID and group ID of the file. -!! -!!##EXAMPLE -!! -!! -!! Sample program: -!! -!! program demo_system_chown -!! use M_system, only : system_chown -!! use M_system, only : system_getuid -!! use M_system, only : system_getgid -!! use M_system, only : system_perror -!! implicit none -!! integer :: i -!! character(len=80),parameter :: names(*)=[character(len=80) :: 'myfile1','/usr/local'] -!! do i=1,size(names) -!! if(.not. system_chown(& -!! & trim(names(i)), & -!! & system_getuid(), & -!! & system_getgid()) & -!! )then -!! call system_perror('*demo_system_chown* '//trim(names(i))) -!! endif -!! enddo -!! end program demo_system_chown +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: change file owner and group +! +!# System_Chown +! +! Elemental impure logical function system_chown(path,owner,group) +! +! The chown(3f) function changes owner and group of a file +! +! The path argument points to a pathname naming a file. The +! user ID and group ID of the named file shall be set to the numeric +! values contained in owner and group, respectively. +! +! Only processes with an effective user ID equal to the user ID of +! the file or with appropriate privileges may change the ownership +! of a file. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Chown_test_1.F90" %}} +!``` INTERFACE MODULE ELEMENTAL IMPURE FUNCTION System_Chown(dirname, owner, group) - CHARACTER(len=*), INTENT(in) :: dirname - INTEGER, INTENT(in) :: owner - INTEGER, INTENT(in) :: group + CHARACTER(*), INTENT(IN) :: dirname + !! A character string representing a file pathname. + !! Trailing spaces are ignored. + INTEGER, INTENT(IN) :: owner + !! UID of owner that ownership is to be changed to + INTEGER, INTENT(IN) :: group + !! GID of group that ownership is to be changed to LOGICAL :: System_Chown + !! The system_chown(3f) function should return zero 0 if successful. + !! Otherwise, these functions shall return 1 and set errno to + !! indicate the error. If 1 is returned, no changes are made in + !! the user ID and group ID of the file. END FUNCTION System_Chown END INTERFACE @@ -1317,1966 +882,1200 @@ END FUNCTION System_Chown ! !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_cpu_time(3f) - [M_system] get processor time by calling times(3c) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_cpu_time(c_user, c_system, c_total) -!! -!! real,intent(out) :: c_total -!! real,intent(out) :: c_user -!! real,intent(out) :: c_system -!! -!!##DESCRIPTION -!! -!!##OUTPUT -!! c_total total processor time ( c_user + c_system ) -!! c_user processor user time -!! c_system processor system time -!! -!!##ERRORS -!! No errors are defined. -!! -!!##EXAMPLES -!! -!! -!! Sample program: -!! -!! program demo_system_cpu_time -!! -!! use M_system, only : system_cpu_time -!! use ISO_C_BINDING, only : c_float -!! implicit none -!! real :: user_start, system_start, total_start -!! real :: user_finish, system_finish, total_finish -!! integer :: i -!! integer :: itimes=1000000 -!! real :: value -!! -!! call system_cpu_time(total_start,user_start,system_start) -!! -!! value=0.0 -!! do i=1,itimes -!! value=sqrt(real(i)+value) -!! enddo -!! write(10,*)value -!! flush(10) -!! write(*,*)'average sqrt value=',value/itimes -!! call system_cpu_time(total_finish,user_finish,system_finish) -!! write(*,*)'USER ......',user_finish-user_start -!! write(*,*)'SYSTEM ....',system_finish-system_start -!! write(*,*)'TOTAL .....',total_finish-total_start -!! -!! end program demo_system_cpu_time -!! -!! Typical Results: -!-! GET ERRORS ABOUT MISSING LONGEST_ENV_VARIABLE IN GFORTRAN 6.4.0 IF JUST USE INTERFACE INSTEAD OF MAKING SUBROUTINE -!-!interface -!-! subroutine system_cpu_time(c_total,c_user,c_system) bind (C,NAME='my_cpu_time') -!-! import c_float -!-! real(kind=c_float) :: c_user,c_system,c_total -!-! end subroutine system_cpu_time -!-!end interface +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get processor time by calling times +! +!# System_Cpu_Time +! +! Get processor time by calling times +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Cpu_Time" %}} +!``` INTERFACE - MODULE SUBROUTINE system_cpu_time(total, user, system) + MODULE SUBROUTINE System_Cpu_Time(total, user, system) REAL, INTENT(OUT) :: user, system, total - END SUBROUTINE system_cpu_time + !! C_Total total processor time ( C_User + C_System ) + !! C_User processor user time + !! C_System processor system time + END SUBROUTINE System_Cpu_Time END INTERFACE !---------------------------------------------------------------------------- -! +! System_Link@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_link(3f) - [M_system:FILE_SYSTEM] link one file to another -!! file relative to two directory file descriptors -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure integer function link(oldpath,newpath); -!! -!! character(len=*),intent(in) :: oldpath -!! character(len=*),intent(in) :: newpath -!! -!!##DESCRIPTION -!! The link() function shall create a new link (directory entry) -!! for the existing file, path1. -!! -!! The path1 argument points to a pathname naming an existing -!! file. The path2 argument points to a pathname naming the -!! new directory entry to be created. The link() function shall -!! atomically create a new link for the existing file and the link -!! count of the file shall be incremented by one. -!! -!! If path1 names a directory, link() shall fail unless the process -!! has appropriate privileges and the implementation supports using -!! link() on directories. -!! -!! If path1 names a symbolic link, it is implementation-defined -!! whether link() follows the symbolic link, or creates a new link -!! to the symbolic link itself. -!! -!! Upon successful completion, link() shall mark for update the -!! last file status change timestamp of the file. Also, the last -!! data modification and last file status change timestamps of the -!! directory that contains the new entry shall be marked for update. -!! -!! If link() fails, no link shall be created and the link count of -!! the file shall remain unchanged. -!! -!! The implementation may require that the calling process has -!! permission to access the existing file. -!! -!! The linkat() function shall be equivalent to the link() function -!! except that symbolic links shall be handled as specified by the -!! value of flag (see below) and except in the case where either path1 -!! or path2 or both are relative paths. In this case a relative path -!! path1 is interpreted relative to the directory associated with -!! the file descriptor fd1 instead of the current working directory -!! and similarly for path2 and the file descriptor fd2. If the -!! file descriptor was opened without O_SEARCH, the function shall -!! check whether directory searches are permitted using the current -!! permissions of the directory underlying the file descriptor. If -!! the file descriptor was opened with O_SEARCH, the function shall -!! not perform the check. -!! -!! Values for flag are constructed by a bitwise-inclusive OR of -!! flags from the following list, defined in : -!! -!! AT_SYMLINK_FOLLOW -!! If path1 names a symbolic link, a new link for the target -!! of the symbolic link is created. -!! -!! If linkat() is passed the special value AT_FDCWD in the fd1 or -!! fd2 parameter, the current working directory shall be used for the -!! respective path argument. If both fd1 and fd2 have value AT_FDCWD, -!! the behavior shall be identical to a call to link(), except that -!! symbolic links shall be handled as specified by the value of flag. -!! -!! Some implementations do allow links between file systems. -!! -!! If path1 refers to a symbolic link, application developers should -!! use linkat() with appropriate flags to select whether or not the -!! symbolic link should be resolved. -!! -!! If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and -!! the path1 argument names a symbolic link, a new link is created -!! for the symbolic link path1 and not its target. -!! -!!##RETURN VALUE -!! Upon successful completion, these functions shall return -!! 0. Otherwise, these functions shall return -1 and set errno to -!! indicate the error. -!! -!!##EXAMPLES -!! -!! Creating a Link to a File -!! -!! program demo_system_link -!! use M_system, only : system_link, system_perror -!! integer :: ierr -!! ierr = system_link('myfile1','myfile2') -!! if(ierr.ne.0)then -!! call system_perror('*demo_system_link*') -!! endif -!! end program demo_system_link + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: link one file to another file relative to two directory +! descriptors +! +!# System_Link +! +! The link() function shall create a new link (directory entry) +! for the existing file, path1. +! +! The path1 argument points to a pathname naming an existing +! file. The path2 argument points to a pathname naming the +! new directory entry to be created. The link() function shall +! atomically create a new link for the existing file and the link +! count of the file shall be incremented by one. +! +! If path1 names a directory, link() shall fail unless the process +! has appropriate privileges and the implementation supports using +! link() on directories. +! +! If path1 names a symbolic link, it is implementation-defined +! whether link() follows the symbolic link, or creates a new link +! to the symbolic link itself. +! +! Upon successful completion, link() shall mark for update the +! last file status change timestamp of the file. Also, the last +! data modification and last file status change timestamps of the +! directory that contains the new entry shall be marked for update. +! +! If link() fails, no link shall be created and the link count of +! the file shall remain unchanged. +! +! The implementation may require that the calling process has +! permission to access the existing file. +! +! The linkat() function shall be equivalent to the link() function +! except that symbolic links shall be handled as specified by the +! value of flag (see below) and except in the case where either path1 +! or path2 or both are relative paths. In this case a relative path +! path1 is interpreted relative to the directory associated with +! the file descriptor fd1 instead of the current working directory +! and similarly for path2 and the file descriptor fd2. If the +! file descriptor was opened without O_SEARCH, the function shall +! check whether directory searches are permitted using the current +! permissions of the directory underlying the file descriptor. If +! the file descriptor was opened with O_SEARCH, the function shall +! not perform the check. +! +! Values for flag are constructed by a bitwise-inclusive OR of +! flags from the following list, defined in : +! +! AT_SYMLINK_FOLLOW +! If path1 names a symbolic link, a new link for the target +! of the symbolic link is created. +! +! If linkat() is passed the special value AT_FDCWD in the fd1 or +! fd2 parameter, the current working directory shall be used for the +! respective path argument. If both fd1 and fd2 have value AT_FDCWD, +! the behavior shall be identical to a call to link(), except that +! symbolic links shall be handled as specified by the value of flag. +! +! Some implementations do allow links between file systems. +! +! If path1 refers to a symbolic link, application developers should +! use linkat() with appropriate flags to select whether or not the +! symbolic link should be resolved. +! +! If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and +! the path1 argument names a symbolic link, a new link is created +! for the symbolic link path1 and not its target. INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION system_link(oldname, newname) RESULT(ierr) - CHARACTER(len=*), INTENT(in) :: oldname - CHARACTER(len=*), INTENT(in) :: newname + MODULE ELEMENTAL IMPURE FUNCTION System_Link(oldname, newname) RESULT(ierr) + CHARACTER(len=*), INTENT(IN) :: oldname + CHARACTER(len=*), INTENT(IN) :: newname INTEGER :: ierr - END FUNCTION system_link + !! Upon successful completion, these functions shall return + !! 0. Otherwise, these functions shall return -1 and set errno to + !! indicate the error. + END FUNCTION System_Link END INTERFACE !---------------------------------------------------------------------------- -! +! System_Unlink@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_unlink(3f) - [M_system:FILE_SYSTEM] remove a directory -!! entry relative to directory file descriptor -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! elemental impure integer function unlink(path); -!! -!! character(len=*) :: path -!! -!!##DESCRIPTION -!! The unlink() function shall remove a link to a file. If path names a -!! symbolic link, unlink() shall remove the symbolic link named by path -!! and shall not affect any file or directory named by the contents of -!! the symbolic link. Otherwise, unlink() shall remove the link named by -!! the pathname pointed to by path and shall decrement the link count of -!! the file referenced by the link. -!! -!! When the files link count becomes 0 and no process has the file open, -!! the space occupied by the file shall be freed and the file shall no -!! longer be accessible. If one or more processes have the file open when -!! the last link is removed, the link shall be removed before unlink() -!! returns, but the removal of the file contents shall be postponed until -!! all references to the file are closed. -!! -!! The path argument shall not name a directory unless the process has -!! appropriate privileges and the implementation supports using unlink() -!! on directories. -!! -!! Upon successful completion, unlink() shall mark for update the last -!! data modification and last file status change timestamps of the parent -!! directory. Also, if the file link count is not 0, the last file status -!! change timestamp of the file shall be marked for update. -!! -!! Values for flag are constructed by a bitwise-inclusive OR of flags from -!! the following list, defined in : -!! -!! AT_REMOVEDIR -!! -!! Remove the directory entry specified by fd and path as a -!! directory, not a normal file. -!! -!!##RETURN VALUE -!! -!! Upon successful completion, these functions shall return 0. Otherwise, -!! these functions shall return -1 and set errno to indicate the error. If -!! -1 is returned, the named file shall not be changed. -!! -!!##EXAMPLES -!! -!! Removing a link to a file -!! -!! program demo_system_unlink -!! use M_system, only : system_unlink, system_perror -!! integer :: ierr -!! ierr = system_unlink('myfile1') -!! if(ierr.ne.0)then -!! call system_perror('*demo_system_unlink*') -!! endif -!! end program demo_system_unlink + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: remove a directory entry relative to directory file descriptor +! +!# System_Unlink +! +! The unlink() function shall remove a link to a file. If path names a +! symbolic link, unlink() shall remove the symbolic link named by path +! and shall not affect any file or directory named by the contents of +! the symbolic link. Otherwise, unlink() shall remove the link named by +! the pathname pointed to by path and shall decrement the link count of +! the file referenced by the link. +! +! When the files link count becomes 0 and no process has the file open, +! the space occupied by the file shall be freed and the file shall no +! longer be accessible. If one or more processes have the file open when +! the last link is removed, the link shall be removed before unlink() +! returns, but the removal of the file contents shall be postponed until +! all references to the file are closed. +! +! The path argument shall not name a directory unless the process has +! appropriate privileges and the implementation supports using unlink() +! on directories. +! +! Upon successful completion, unlink() shall mark for update the last +! data modification and last file status change timestamps of the parent +! directory. Also, if the file link count is not 0, the last file status +! change timestamp of the file shall be marked for update. +! +! Values for flag are constructed by a bitwise-inclusive OR of flags from +! the following list, defined in : +! +! AT_REMOVEDIR +! +! Remove the directory entry specified by fd and path as a +! directory, not a normal file. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Unlink_test_1.F90" %}} +!``` INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION system_unlink(fname) RESULT(ierr) + MODULE ELEMENTAL IMPURE FUNCTION System_Unlink(fname) RESULT(ierr) CHARACTER(len=*), INTENT(in) :: fname INTEGER :: ierr - END FUNCTION system_unlink + !! Upon successful completion, these functions shall return 0. Otherwise, + !! these functions shall return -1 and set errno to indicate the error. + !! If -1 is returned, the named file shall not be changed. + END FUNCTION System_Unlink END INTERFACE !---------------------------------------------------------------------------- -! +! System_Setumask@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_setumask(3f) - [M_system:FILE_SYSTEM] set the file mode creation umask -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer function system_setumask(new_umask) result (old_umask) -!! -!! integer,intent(in) :: new_umask -!! integer(kind=c_int) :: umask_c -!! -!!##DESCRIPTION -!! The system_umask(3f) function sets the file mode creation mask of the -!! process to cmask and return the previous value of the mask. Only -!! the file permission bits of cmask (see ) are used; -!! the meaning of the other bits is implementation-defined. -!! -!! The file mode creation mask of the process is used to turn off -!! permission bits in the mode argument supplied during calls to -!! the following functions: -!! -!! * open(), openat(), creat(), mkdir(), mkdirat(), mkfifo(), and mkfifoat() -!! * mknod(), mknodat() -!! * mq_open() -!! * sem_open() -!! -!! Bit positions that are set in cmask are cleared in the mode of -!! the created file. -!! -!!##RETURN VALUE -!! The file permission bits in the value returned by umask() shall be -!! the previous value of the file mode creation mask. The state of any -!! other bits in that value is unspecified, except that a subsequent -!! call to umask() with the returned value as cmask shall leave the -!! state of the mask the same as its state before the first call, -!! including any unspecified use of those bits. -!! -!!##ERRORS -!! No errors are defined. -!! -!!##EXAMPLE -!! -!! Sample program -!! -!! program demo_setumask -!! use M_system, only : system_getumask, system_setumask -!! integer :: newmask -!! integer :: i -!! integer :: old_umask -!! write(*,101)(system_getumask(),i=1,4) -!! 101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'") -!! newmask=63 -!! old_umask=system_setumask(newmask) -!! write(*,*)'NEW' -!! write(*,101)(system_getumask(),i=1,4) -!! end program demo_setumask -!! -!! Expected output -!! -!! 18 O'022' Z"12' B'000010010" -!! NEW -!! 63 O'077' Z"3F' B'000111111" + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Set the file mode creation umask +! +!# System_Setumask +! +! The `system_umask(3f)` function sets the file mode creation mask of +! the calling process to `cmask` and returns the previous value of +! the mask. +! +! Only the file permission bits of `cmask` (see ``) are +! used. The interpretation of any other bits is +! implementation-defined. +! +!### Effect of the file creation mask +! +! The file mode creation mask is applied to the `mode` argument +! supplied to the following functions: +! +! - `open()`, `openat()`, `creat()` +! - `mkdir()`, `mkdirat()`, `mkfifo()`, `mkfifoat()` +! - `mknod()`, `mknodat()` +! - `mq_open()` +! - `sem_open()` +! +!## Semantics +! +! - Bit positions that are set in `cmask` are cleared in the `mode` +! of any subsequently created file or object. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Setumask_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_setumask(umask_value) RESULT(old_umask) - INTEGER, INTENT(in) :: umask_value - INTEGER :: old_umask - END FUNCTION system_setumask + MODULE FUNCTION System_Setumask(Umask_Value) RESULT(Old_Umask) + INTEGER, INTENT(in) :: Umask_Value + INTEGER :: Old_Umask + !! The file permission bits in the value returned by umask() shall be + !! the previous value of the file mode creation mask. The state of any + !! other bits in that value is unspecified, except that a subsequent + !! call to umask() with the returned value as cmask shall leave the + !! state of the mask the same as its state before the first call, + !! including any unspecified use of those bits. + END FUNCTION System_Setumask END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getumask@GetMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_getumask(3f) - [M_system:QUERY_FILE] get current umask -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! integer function system_getumask() result (umask_value) -!!##DESCRIPTION -!! The return value from getumask(3f) is the value of the file -!! creation mask, obtained by using umask(3c). -!!##EXAMPLE -!! -!! Sample program -!! -!! program demo_getumask -!! use M_system, only : system_getumask, system_setumask -!! integer :: i -!! write(*,101)(system_getumask(),i=1,4) -!! 101 format(1x,i0,1x,"O'",o4.4,"'",1x,'Z"',z0,"'",1x,"B'",b12.12,"'") -!! end program demo_getumask -!! -!! Expected output -!! -!! 18 O'022' Z"12' B'000010010" + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get current umask +! +!# System_Getumask +! +! The return value from getumask(3f) is the value of the file +! creation mask, obtained by using umask(3c). +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getumask_test_1.F90" %}} +!``` + INTERFACE - MODULE FUNCTION system_getumask() RESULT(umask_value) -! The return value from umask() is just the previous value of the file -! creation mask, so that this system call can be used both to get and -! set the required values. Sadly, however, there is no way to get the old -! umask value without setting a new value at the same time. - -! This means that in order just to see the current value, it is necessary -! to execute a piece of code like the following function: - INTEGER :: umask_value - END FUNCTION system_getumask + MODULE FUNCTION System_Getumask() RESULT(Umask_Value) + INTEGER :: Umask_Value + !! The return value from umask() is just the previous value of the file + !! creation mask, so that this system call can be used both to get and + !! set the required values. Sadly, however, + !! there is no way to get the old + !! umask value without setting a new value at the same time. + !! This means that in order just to see the current value, + !! it is necessary + !! to execute a piece of code like the following function: + END FUNCTION System_Getumask END INTERFACE !---------------------------------------------------------------------------- -! +! System_Perror@GetMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! perror(3f) - [M_system:ERROR_PROCESSING] print error message for last C error on stderr -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_perror(prefix) -!! -!! character(len=*),intent(in) :: prefix -!! -!!##DESCRIPTION -!! Use system_perror(3f) to print an error message on stderr -!! corresponding to the current value of the C global variable errno. -!! Unless you use NULL as the argument prefix, the error message will -!! begin with the prefix string, followed by a colon and a space -!! (:). The remainder of the error message produced is one of the -!! strings described for strerror(3c). -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_perror -!! use M_system, only : system_perror,system_rmdir -!! implicit none -!! character(len=:),allocatable :: DIRNAME -!! DIRNAME='/NOT/THERE/OR/ANYWHERE' -!! ! generate an error with a routine that supports errno and perror(3c) -!! if(system_rmdir(DIRNAME).ne.0)then -!! call system_perror('*demo_system_perror*:'//DIRNAME) -!! endif -!! write(*,'(a)')"That is all Folks!" -!! end program demo_system_perror -!! -!! Expected results: -!! -!! *demo_system_perror*:/NOT/THERE/OR/ANYWHERE: No such file or directory -!! That is all Folks! +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: print error message for last C error on stderr +! +!# System_Perror +! +! Use system_perror(3f) to print an error message on stderr +! corresponding to the current value of the C global variable errno. +! Unless you use NULL as the argument prefix, the error message will +! begin with the prefix string, followed by a colon and a space +! (:). The remainder of the error message produced is one of the +! strings described for strerror(3c). +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Perror_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_perror(prefix) - CHARACTER(len=*), INTENT(in) :: prefix - END SUBROUTINE system_perror + MODULE SUBROUTINE System_Perror(prefix) + CHARACTER(len=*), INTENT(IN) :: prefix + END SUBROUTINE System_Perror END INTERFACE !---------------------------------------------------------------------------- -! +! System_Chdir@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_chdir(3f) - [M_system_FILE_SYSTEM] call chdir(3c) from Fortran to change working directory -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_chdir(path, err) -!! -!! character(len=*) :: path -!! integer, optional, intent(out) :: err -!! -!!##DESCRIPTION -!! -!! system_chdir(3f) changes the current working directory of the calling -!! process to the directory specified in path. The current working -!! directory is the starting point for interpreting relative pathnames -!! (those not starting with '/'). -!! -!!##RETURN VALUE -!! -!! On success, zero is returned. On error, -1 is returned, and errno is -!! set appropriately. -!! -!! -!! Depending on the file system, other errors can be returned. The more -!! general errors for chdir() are listed below, by their C definitions: -!! -!! Errors -!! EACCES Search permission is denied for one of the components of path. -!! (See also path_resolution(7).) -!! EFAULT path points outside your accessible address space. -!! EIO An I/O error occurred. -!! ELOOP Too many symbolic links were encountered in resolving path. -!! ENAMETOOLONG path is too long. -!! ENOENT The file does not exist. -!! ENOMEM Insufficient kernel memory was available. -!! ENOTDIR A component of path is not a directory. -!! -!!##SEE ALSO -!! -!! chroot(2), getcwd(3), path_resolution(7) -!! -!!##EXAMPLE -!! -!! Change working directory from Fortran -!! -!! program demo_system_chdir -!! use M_system, only : system_chdir -!! implicit none -!! integer :: ierr -!! -!! call execute_command_line('pwd') -!! call system_chdir('/tmp',ierr) -!! call execute_command_line('pwd') -!! write(*,*)'*CHDIR TEST* IERR=',ierr -!! -!! end program demo_system_chdir -!! -!!##RESULTS: -!! Sample run output: -!! -!! /home/urbanjs/V600 -!! /tmp -!! *CHDIR TEST* IERR= 0 +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: change working directory +! +!# System_Chdir +! +! The `system_chdir(3f)` procedure changes the current working directory +! of the calling process to the directory specified by `path`. +! +! The current working directory is used as the starting point for +! interpreting relative pathnames (those not beginning with `/`). +! +!## Errors +! +! On failure, an error condition is reported as described below. The +! specific error returned may depend on the underlying file system. +! +! The following errors correspond to the C `chdir()` definitions: +! +! - `EACCES` +! Search permission is denied for one of the components of `path`. +! See also `path_resolution(7)`. +! +! - `EFAULT` +! `path` points outside the accessible address space. +! +! - `EIO` +! An I/O error occurred. +! +! - `ELOOP` +! Too many symbolic links were encountered while resolving `path`. +! +! - `ENAMETOOLONG` +! `path` is too long. +! +! - `ENOENT` +! The specified file does not exist. +! +! - `ENOMEM` +! Insufficient kernel memory was available. +! +! - `ENOTDIR` +! A component of `path` is not a directory. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Chdir_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_chdir(path, err) - CHARACTER(len=*) :: path - INTEGER, OPTIONAL, INTENT(out) :: err - END SUBROUTINE system_chdir + MODULE SUBROUTINE System_Chdir(path, err) + CHARACTER(len=*), INTENT(IN) :: path + INTEGER, OPTIONAL, INTENT(OUT) :: err + !! On success, zero is returned. On error, -1 is returned, and errno is + !! set appropriately. + END SUBROUTINE System_Chdir END INTERFACE !---------------------------------------------------------------------------- -! +! System_Remove@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_remove(3f) - [M_system_FILE_SYSTEM] call remove(3c) to remove file -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! elemental impure function system_remove(path) result(err) -!! -!! character(*),intent(in) :: path -!! integer(c_int) :: err -!! -!!##DESCRIPTION -!! Fortran supports scratch files via the OPEN(3c) command; but does -!! not otherwise allow for removing files. The system_remove(3f) command -!! allows for removing files by name that the user has the authority to -!! remove by calling the C remove(3c) function. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_remove -!! use M_system, only : system_remove -!! character(len=*),parameter :: FILE='MyJunkFile.txt' -!! integer :: ierr -!! write(*,*)'BEFORE CREATED '//FILE -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! ! note intentionally causes error if file exists -!! open(unit=10,file=FILE,status='NEW') -!! write(*,*)'AFTER OPENED '//FILE -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! write(10,'(a)') 'This is a file I want to delete' -!! close(unit=10) -!! write(*,*)'AFTER CLOSED ' -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! ierr=system_remove(FILE) -!! write(*,*)'AFTER REMOVED',IERR -!! call execute_command_line('ls -l '//FILE) -!! write(*,*) -!! -!! end program demo_system_remove -!! -!! Expected Results: -!! -!! > BEFORE CREATED MyJunkFile.txt -!! > ls: cannot access 'MyJunkFile.txt': No such file or directory -!! > -!! > AFTER OPENED MyJunkFile.txt -!! > -rw-r--r-- 1 JSU None 0 Nov 19 19:32 MyJunkFile.txt -!! > -!! > AFTER CLOSED -!! > -rw-r--r-- 1 JSU None 32 Nov 19 19:32 MyJunkFile.txt -!! > -!! > AFTER REMOVED 0 -!! > ls: cannot access 'MyJunkFile.txt': No such file or directory -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: remove a file +! +!# System_Remove +! +! Fortran supports scratch files via the OPEN(3c) command; but does +! not otherwise allow for removing files. The system_remove(3f) command +! allows for removing files by name that the user has the authority to +! remove by calling the C remove(3c) function. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Remove_test_1.F90" %}} +!``` INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION system_remove(path) RESULT(err) + MODULE ELEMENTAL IMPURE FUNCTION System_Remove(path) RESULT(err) CHARACTER(*), INTENT(in) :: path INTEGER(C_INT) :: err - END FUNCTION system_remove + END FUNCTION System_Remove END INTERFACE !---------------------------------------------------------------------------- -! +! System_Rename@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_rename(3f) - [M_system_FILE_SYSTEM] call rename(3c) to rename a system file -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_rename(input,output) result(ierr) -!! -!! character(*),intent(in) :: input,output -!! integer :: ierr -!!##DESCRIPTION -!! Rename a file by calling rename(3c). It is not recommended that the -!! rename occur while either filename is being used on a file currently -!! OPEN(3f) by the program. -!! -!! Both the old and new names must be on the same device. -!!##OPTIONS -!! INPUT system filename of an existing file to rename -!! OUTPUT system filename to be created or overwritten by INPUT file. -!! Must be on the same device as the INPUT file. -!!##RETURNS -!! IERR zero (0) if no error occurs. If not zero a call to -!! system_errno(3f) or system_perror(3f) is supported -!! to diagnose error -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rename -!! use M_system, only : system_rename -!! use M_system, only : system_remove -!! use M_system, only : system_perror -!! implicit none -!! character(len=256) :: string -!! integer :: ios, ierr -!! -!! ! try to remove junk files just in case -!! ierr=system_remove('_scratch_file_') -!! write(*,'(a,i0)') 'should not be zero ',ierr -!! call system_perror('*demo_system_rename*') -!! ierr=system_remove('_renamed_scratch_file_') -!! write(*,'(a,i0)') 'should not be zero ',ierr -!! call system_perror('*demo_system_rename*') -!! -!! ! create scratch file to rename -!! open(unit=10,file='_scratch_file_',status='new') -!! write(10,'(a)') 'Test by renaming "_scratch_file_" to "_renamed_scratch_file_"' -!! write(10,'(a)') 'IF YOU SEE THIS ON OUTPUT THE RENAME WORKED' -!! close(10) -!! ! rename scratch file -!! ierr=system_rename('_scratch_file_','_renamed_scratch_file_') -!! if(ierr.ne.0)then -!! write(*,*)'ERROR RENAMING FILE ',ierr -!! endif -!! ! read renamed file -!! open(unit=11,file='_renamed_scratch_file_',status='old') -!! INFINITE: do -!! read(11,'(a)',iostat=ios)string -!! if(ios.ne.0)exit INFINITE -!! write(*,'(a)')trim(string) -!! enddo INFINITE -!! close(unit=11) -!! -!! ! clean up -!! ierr=system_remove('_scratch_file_') -!! write(*,'(a,i0)') 'should not be zero ',ierr -!! ierr=system_remove('_renamed_scratch_file_') -!! write(*,'(a,i0)') 'should be zero ',ierr -!! -!! end program demo_system_rename -!! -!! Expected output: -!! -!! > should not be zero -1 -!! > *demo_system_rename*: No such file or directory -!! > should not be zero -1 -!! > *demo_system_rename*: No such file or directory -!! > Test by renaming "_scratch_file_" to "_renamed_scratch_file_" -!! > IF YOU SEE THIS ON OUTPUT THE RENAME WORKED -!! > should not be zero -1 -!! > should be zero 0 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: rename a system file +! +!# System_Rename +! +! Rename a file by calling rename(3c). It is not recommended that the +! rename occur while either filename is being used on a file currently +! OPEN(3f) by the program. +! Both the old and new names must be on the same device. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Rename_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_rename(input, output) RESULT(ierr) - CHARACTER(*), INTENT(in) :: input, output + MODULE FUNCTION System_Rename(input, output) RESULT(ierr) + CHARACTER(*), INTENT(IN) :: input, output + !! system filename of an existing file to rename + !! system filename to be created or overwritten by INPUT file. + !! Must be on the same device as the INPUT file. INTEGER :: ierr - END FUNCTION system_rename + !! zero (0) if no error occurs. If not zero a call to + !! system_errno(3f) or system_perror(3f) is supported + !! to diagnose error + END FUNCTION System_Rename END INTERFACE !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_chmod(3f) - [M_system_FILE_SYSTEM] call chmod(3c) to change -!! permission mode of a file relative to directory file descriptor -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_chmod(filename,mode) result(ierr) -!! -!! character(len=*),intent(in) :: filename -!! integer,value,intent(in) :: mode -!! integer :: ierr -!! -!!##DESCRIPTION -!! The system_chmod(3f) function shall change UID, _ISGID, S_ISVTX, and the -!! file permission bits of the file named by the pathname pointed -!! to by the path argument to the corresponding bits in the mode -!! argument. The application shall ensure that the effective user -!! ID of the process matches the owner of the file or the process -!! has appropriate privileges in order to do this. -!! -!! S_ISUID, S_ISGID, S_ISVTX, and the file permission bits are -!! described in . -!! -!! If the calling process does not have appropriate privileges, -!! and if the group ID of the file does not match the effective -!! group ID or one of the supplementary group IDs and if the file -!! is a regular file, bit S_ISGID (set-group-ID on execution) in the -!! file mode shall be cleared upon successful return from chmod(). -!! -!! Additional implementation-defined restrictions may cause the -!! S_ISUID and S_ISGID bits in mode to be ignored. -!! -!! Upon successful completion, system_chmod() marks for update the -!! last file status change timestamp of the file. -!! -!! Values for flag are constructed by a bitwise-inclusive OR of -!! flags from the following list, defined in : -!! -!! AT_SYMLINK_NOFOLLOW -!! If path names a symbolic link, then the mode of the symbolic -!! link is changed. -!! -!! -!!##RETURN VALUE -!! Upon successful completion, system_chmod(3f) returns 0. -!! Otherwise, it returns -1 and sets errno to indicate the error. If -!! -1 is returned, no change to the file mode occurs. -!! -!!##EXAMPLES -!! -!! Sample program: -!! -!! program demo_system_chmod -!! use M_system, only : system_chmod -!! use M_system, only : system_stat -!! use M_system, only : R_GRP,R_OTH,R_USR, RWX_G, RWX_U, W_OTH, X_GRP -!! !use M_system, only : RWX_O, W_GRP,W_USR,X_OTH,X_USR -!! !use M_system, only : DEFFILEMODE, ACCESSPERMS -!! use,intrinsic :: iso_fortran_env, only : int64 -!! implicit none -!! integer :: ierr -!! integer :: status -!! integer(kind=int64) :: buffer(13) -!! !Setting Read Permissions for User, Group, and Others -!! ! The following example sets read permissions for the owner, group, and others. -!! open(file='_test1',unit=10) -!! write(10,*)'TEST FILE 1' -!! close(unit=10) -!! ierr=system_chmod('_test1', IANY([R_USR,R_GRP,R_OTH])) -!! -!! !Setting Read, Write, and Execute Permissions for the Owner Only -!! ! The following example sets read, write, and execute permissions for the owner, and no permissions for group and others. -!! open(file='_test2',unit=10) -!! write(10,*)'TEST FILE 2' -!! close(unit=10) -!! ierr=system_chmod('_test2', RWX_U) -!! -!! !Setting Different Permissions for Owner, Group, and Other -!! ! The following example sets owner permissions for CHANGEFILE to read, write, and execute, group permissions to read and -!! ! execute, and other permissions to read. -!! open(file='_test3',unit=10) -!! write(10,*)'TEST FILE 3' -!! close(unit=10) -!! ierr=system_chmod('_test3', IANY([RWX_U,R_GRP,X_GRP,R_OTH])); -!! -!! !Setting and Checking File Permissions -!! ! The following example sets the file permission bits for a file named /home/cnd/mod1, then calls the stat() function to -!! ! verify the permissions. -!! -!! ierr=system_chmod("home/cnd/mod1", IANY([RWX_U,RWX_G,R_OTH,W_OTH])) -!! call system_stat("home/cnd/mod1", buffer,status) -!! -!! ! In order to ensure that the S_ISUID and S_ISGID bits are set, an application requiring this should use stat() after a -!! ! successful chmod() to verify this. -!! -!! ! Any files currently open could possibly become invalid if the mode -!! ! of the file is changed to a value which would deny access to -!! ! that process. -!! -!! end program demo_system_chmod -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain - +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: call chmod(3c) to change permission mode of a file +! relative to directory file descriptor +! +!# System_Chmod +! +! The `system_chmod(3f)` function changes the `S_ISUID`, `S_ISGID`, +! `S_ISVTX`, and file permission bits of the file specified by `path` +! to the corresponding bits in the `mode` argument. +! +! The application shall ensure that the effective user ID of the +! calling process matches the owner of the file, or that the process +! has sufficient privileges. +! +! The constants `S_ISUID`, `S_ISGID`, `S_ISVTX`, and the file +! permission bits are defined in ``. +! +!## Privilege and group semantics +! +! - If the calling process lacks appropriate privileges, and +! the group ID of the file does not match the effective group ID +! or any supplementary group ID, then `S_ISGID` is cleared on +! successful return when the file is a regular file. +! +! - Additional implementation-defined restrictions may cause the +! `S_ISUID` and `S_ISGID` bits in `mode` to be ignored. +! +!## Timestamps +! +! - Upon successful completion, `system_chmod()` marks the last +! file status change timestamp of the file for update. +! +!## Flags +! +! Values for `flag` are constructed using a bitwise-inclusive OR of +! the following values defined in ``: +! +! - `AT_SYMLINK_NOFOLLOW` +! If `path` names a symbolic link, the mode of the symbolic link +! itself is changed rather than the target. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Chmod_test_1.F90" %}} +!``` +! INTERFACE - MODULE FUNCTION system_chmod(filename, mode) RESULT(ierr) - CHARACTER(len=*), INTENT(in) :: filename - INTEGER, VALUE, INTENT(in) :: mode + MODULE FUNCTION System_Chmod(filename, mode) RESULT(ierr) + CHARACTER(*), INTENT(IN) :: filename + INTEGER, VALUE, INTENT(IN) :: mode INTEGER :: ierr - END FUNCTION system_chmod + !! Upon successful completion, system_chmod(3f) returns 0. + !! Otherwise, it returns -1 and sets errno to indicate the error. If + !! -1 is returned, no change to the file mode occurs. + END FUNCTION System_Chmod END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getcwd@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_getcwd(3f) - [M_system:QUERY_FILE] call getcwd(3c) to get the pathname of the current working directory -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_getcwd(output,ierr) -!! -!! character(len=:),allocatable,intent(out) :: output -!! integer,intent(out) :: ierr -!!##DESCRIPTION -!! system_getcwd(3f) calls the C routine getcwd(3c) to obtain the absolute pathname of the current working directory. -!! -!!##RETURN VALUE -!! OUTPUT The absolute pathname of the current working directory -!! The pathname shall contain no components that are dot or dot-dot, -!! or are symbolic links. -!! IERR is not zero if an error occurs. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_getcwd -!! use M_system, only : system_getcwd -!! implicit none -!! character(len=:),allocatable :: dirname -!! integer :: ierr -!! call system_getcwd(dirname,ierr) -!! if(ierr.eq.0)then -!! write(*,*)'CURRENT DIRECTORY ',trim(dirname) -!! else -!! write(*,*)'ERROR OBTAINING CURRENT DIRECTORY NAME' -!! endif -!! end program demo_system_getcwd -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get current working directory +! +!# System_Getcwd +! +! Get current working directory +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getcwd_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_getcwd(output, ierr) + MODULE SUBROUTINE System_Getcwd(output, ierr) CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output + !! The absolute pathname of the current working directory + !! The pathname shall contain no components that are dot or dot-dot, + !! or are symbolic links. INTEGER, INTENT(out) :: ierr - END SUBROUTINE system_getcwd + !! ierr is not zero if an error occurs. + END SUBROUTINE System_Getcwd END INTERFACE !---------------------------------------------------------------------------- -! +! System_Rmdir@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_rmdir(3f) - [M_system:FILE_SYSTEM] call rmdir(3c) to remove empty directories -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_rmdir(dirname) result(err) -!! -!! character(*),intent(in) :: dirname -!! integer(c_int) :: err -!! -!!##DESCRIPTION -!! DIRECTORY The name of a directory to remove if it is empty -!! err zero (0) if no error occurred -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rmdir -!! use M_system, only : system_perror -!! use M_system, only : system_rmdir, system_mkdir -!! use M_system, only : RWX_U -!! implicit none -!! integer :: ierr -!! write(*,*)'BEFORE TRY TO CREATE _scratch/' -!! call execute_command_line('ls -ld _scratch') -!! -!! write(*,*)'TRY TO CREATE _scratch/' -!! ierr=system_mkdir('_scratch',RWX_U) -!! write(*,*)'IERR=',ierr -!! call execute_command_line('ls -ld _scratch') -!! -!! write(*,*)'TRY TO REMOVE _scratch/' -!! ierr=system_rmdir('_scratch') -!! write(*,*)'IERR=',ierr -!! call execute_command_line('ls -ld _scratch') -!! -!! write(*,*)'TRY TO REMOVE _scratch when it should be gone/' -!! ierr=system_rmdir('_scratch') -!! call system_perror('*test of system_rmdir*') -!! write(*,*)'IERR=',ierr -!! call execute_command_line('ls -ld _scratch') -!! -!! end program demo_system_rmdir -!! -!! Expected output: -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: remove empty directories +! +!# System_Rmdir +! +! Remove empty directories. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Rmdir_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_rmdir(dirname) RESULT(err) - CHARACTER(*), INTENT(in) :: dirname + MODULE FUNCTION System_Rmdir(dirname) RESULT(err) + CHARACTER(*), INTENT(IN) :: dirname + !! The name of a directory to remove if it is empty INTEGER(C_INT) :: err - END FUNCTION system_rmdir + !! zero (0) if no error occurred + END FUNCTION System_Rmdir END INTERFACE !---------------------------------------------------------------------------- -! +! System_Mkfifo@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_mkfifo(3f) - [M_system:FILE_SYSTEM] make a FIFO special file relative to directory file descriptor -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_mkfifo(pathname,mode) result(ierr) -!! -!! character(len=*),intent(in) :: pathname -!! integer,intent(in) :: mode -!! integer :: ierr -!! -!!##DESCRIPTION -!! A regular pipe can only connect two related processes. It is created by -!! a process and will vanish when the last process closes it. -!! -!! A named pipe, also called a FIFO for its behavior, can be used to connect -!! two unrelated processes and exists independently of the processes; -!! meaning it can exist even if no one is using it. A FIFO is created using -!! the mkfifo() library function. -!! -!! The mkfifo() function creates a new FIFO special file named by the -!! pathname. -!! -!! The file permission bits of the new FIFO are initialized from mode. -!! -!! The file permission bits of the mode argument are modified by the -!! process file creation mask. -!! -!! When bits in mode other than the file permission bits are set, the -!! effect is implementation-defined. -!! -!! If path names a symbolic link, mkfifo() shall fail and set errno to -!! [EEXIST]. -!! -!! The FIFOs user ID will be set to the process effective user ID. -!! -!! The FIFOs group ID shall be set to the group ID of the parent -!! directory or to the effective group ID of the process. -!! -!! Implementations shall provide a way to initialize the FIFOs group -!! ID to the group ID of the parent directory. -!! -!! Implementations may, but need not, provide an implementation-defined -!! way to initialize the FIFOs group ID to the effective group ID of -!! the calling process. -!! -!! Upon successful completion, mkfifo() shall mark for update the -!! last data access, last data modification, and last file status change -!! timestamps of the file. -!! -!! Also, the last data modification and last file status change -!! timestamps of the directory that contains the new entry shall be -!! marked for update. -!! -!! Predefined variables are typically used to set permission modes. -!! -!! You can bytewise-OR together these variables to create the most -!! common permissions mode: -!! -!! User: R_USR (read), W_USR (write), X_USR(execute) -!! Group: R_GRP (read), W_GRP (write), X_GRP(execute) -!! Others: R_OTH (read), W_OTH (write), X_OTH(execute) -!! -!! Additionally, some shortcuts are provided (basically a bitwise-OR -!! combination of the above): -!! -!! Read + Write + Execute: RWX_U (User), RWX_G (Group), RWX_O (Others) -!! DEFFILEMODE: Equivalent of 0666 =rw-rw-rw- -!! ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx -!! -!! Therefore, to give only the user rwx (read+write+execute) rights whereas -!! group members and others may not do anything, you can use any of the -!! following mkfifo() calls equivalently: -!! -!! ierr= mkfifo("myfile", IANY([R_USR, W_USR, X_USR])); -!! ierr= mkfifo("myfile", RWX_U); -!! -!! In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can -!! use any of the following calls equivalently: -!! -!! ierr= mkfifo("myfile",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH])); -!! ierr= mkfifo("myfile",IANY([RWX_U,RWX_G,RWX_O])); -!! ierr= mkfifo("myfile",ACCESSPERMS); -!!##RETURN VALUE -!! Upon successful completion, return 0. -!! Otherwise, return -1 and set errno to indicate the error. -!! If -1 is returned, no FIFO is created. -!! -!!##EXAMPLES -!! -!! The following example shows how to create a FIFO file named -!! /home/cnd/mod_done, with read/write permissions for owner, and -!! with read permissions for group and others. -!! -!! program demo_system_mkfifo -!! use M_system, only : system_mkfifo, system_perror -!! !use M_system, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O -!! !use M_system, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR -!! !use M_system, only : DEFFILEMODE, ACCESSPERMS -!! use M_system, only : W_USR, R_USR, R_GRP, R_OTH -!! implicit none -!! integer :: status -!! status = system_mkfifo("/tmp/buffer", IANY([W_USR, R_USR, R_GRP, R_OTH])) -!! if(status.ne.0)then -!! call system_perror('*mkfifo* error:') -!! endif -!! end program demo_system_mkfifo -!! -!! Now some other process (or this one) can read from /tmp/buffer while this program -!! is running or after, consuming the data as it is read. -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: make a FIFO special file relative to directory file descriptor +! +!# System_Mkfifo +! +! A regular pipe can only connect two related processes. It is created +! by a process and vanishes when the last process closes it. +! +! A named pipe, also known as a FIFO, can connect two unrelated +! processes and exists independently of the processes using it. +! A FIFO is created using the `mkfifo()` library function. +! +!## Behavior and semantics +! +! - `mkfifo()` creates a new FIFO special file specified by `pathname`. +! - The file permission bits of the new FIFO are initialized from +! `mode`. +! - The permission bits specified in `mode` are modified by the +! process file creation mask. +! - If bits other than file permission bits are set in `mode`, +! the effect is implementation-defined. +! - If `pathname` names a symbolic link, `mkfifo()` fails and sets +! `errno` to `EEXIST`. +! - The FIFO user ID is set to the effective user ID of the process. +! - The FIFO group ID is set either to the group ID of the parent +! directory or to the effective group ID of the process. +! - Implementations shall provide a method to initialize the FIFO +! group ID from the parent directory. +! - Implementations may optionally provide a method to initialize +! the FIFO group ID from the effective group ID of the caller. +! - Upon successful completion, the FIFO last access, modification, +! and status change timestamps are marked for update. +! - The directory containing the new FIFO also has its modification +! and status change timestamps updated. +! +!## Permission modes +! +! Predefined variables are typically used to specify permission modes. +! These variables may be combined using a bytewise OR operation. +! +! Permission bits by category: +! +! - **User** +! - `R_USR` : read +! - `W_USR` : write +! - `X_USR` : execute +! +! - **Group** +! - `R_GRP` : read +! - `W_GRP` : write +! - `X_GRP` : execute +! +! - **Others** +! - `R_OTH` : read +! - `W_OTH` : write +! - `X_OTH` : execute +! +!## Shortcut constants +! +! The following predefined constants represent common combinations: +! +! - `RWX_U` : read, write, execute for user +! - `RWX_G` : read, write, execute for group +! - `RWX_O` : read, write, execute for others +! - `DEFFILEMODE` +! Equivalent to octal `0666` (`rw-rw-rw-`) +! - `ACCESSPERMS` +! Equivalent to octal `0777` (`rwxrwxrwx`) +! +!## Examples +! +! To grant read, write, and execute permissions only to the user: +! +! - `ierr = mkfifo("myfile", IANY([R_USR, W_USR, X_USR]))` +! - `ierr = mkfifo("myfile", RWX_U)` +! +! To grant full permissions to all users (mode `0777`): +! +! - `ierr = mkfifo("myfile", IANY([R_USR, W_USR, X_USR, R_GRP, W_GRP, & +! X_GRP, R_OTH, W_OTH, X_OTH]))` +! - `ierr = mkfifo("myfile", IANY([RWX_U, RWX_G, RWX_O]))` +! - `ierr = mkfifo("myfile", ACCESSPERMS)` +! +!```fortran +! {{% fortran-code file="examples/System_Mkfifo_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_mkfifo(pathname, mode) RESULT(err) - CHARACTER(len=*), INTENT(in) :: pathname - INTEGER, INTENT(in) :: mode + MODULE FUNCTION System_Mkfifo(pathname, mode) RESULT(err) + CHARACTER(*), INTENT(IN) :: pathname + INTEGER, INTENT(IN) :: mode INTEGER :: err - END FUNCTION system_mkfifo + !! Upon successful completion, return 0. + !! Otherwise, return -1 and set errno to indicate the error. + !! If -1 is returned, no FIFO is created. + END FUNCTION System_Mkfifo END INTERFACE !---------------------------------------------------------------------------- -! +! System_Mkdir@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_mkdir(3f) - [M_system:FILE_SYSTEM] call mkdir(3c) to create a new directory -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!!##DESCRIPTION -!! -!! Predefined variables are typically used to set permission modes. -!! You can bytewise-OR together these variables to create the most common -!! permissions mode: -!! -!! User: R_USR (read), W_USR (write), X_USR(execute) -!! Group: R_GRP (read), W_GRP (write), X_GRP(execute) -!! Others: R_OTH (read), W_OTH (write), X_OTH(execute) -!! -!! Additionally, some shortcuts are provided (basically a bitwise-OR combination of the above): -!! -!! Read + Write + Execute: RWX_U (User), RWX_G (Group), RWX_O (Others) -!! DEFFILEMODE: Equivalent of 0666 =rw-rw-rw- -!! ACCESSPERMS: Equivalent of 0777 = rwxrwxrwx -!! -!! Therefore, to give only the user rwx (read+write+execute) rights whereas -!! group members and others may not do anything, you can use any of the -!! following mkdir() calls equivalently: -!! -!! ierr= mkdir("mydir", IANY([R_USR, W_USR, X_USR])); -!! ierr= mkdir("mydir", RWX_U); -!! -!! In order to give anyone any rights (mode 0777 = rwxrwxrwx), you can -!! use any of the following calls equivalently: -!! -!! ierr= mkdir("mydir",IANY([R_USR,W_USR,X_USR,R_GRP,W_GRP,X_GRP,R_OTH,W_OTH,X_OTH])); -!! ierr= mkdir("mydir",IANY([RWX_U,RWX_G,RWX_O])); -!! ierr= mkdir("mydir",ACCESSPERMS); -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_mkdir -!! use M_system, only : system_perror -!! use M_system, only : system_mkdir -!! use M_system, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O -!! use M_system, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR -!! use M_system, only : DEFFILEMODE, ACCESSPERMS -!! implicit none -!! integer :: ierr -!! ierr=system_mkdir('_scratch',IANY([R_USR,W_USR,X_USR])) -!! end program demo_system_mkdir -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: call mkdir(3c) to create a new directory +! +!# System_Mkdir +! +! Predefined variables are typically used to set permission modes. +! These variables can be combined using a bytewise OR operation to +! create commonly used permission settings. +! +! Permission bits by category: +! +! - **User** +! - `R_USR` : read +! - `W_USR` : write +! - `X_USR` : execute +! +! - **Group** +! - `R_GRP` : read +! - `W_GRP` : write +! - `X_GRP` : execute +! +! - **Others** +! - `R_OTH` : read +! - `W_OTH` : write +! - `X_OTH` : execute +! +! Additional shortcut constants are provided. These are predefined +! bitwise-OR combinations of the permission flags listed above: +! +! - `RWX_U` : read, write, and execute for user +! - `RWX_G` : read, write, and execute for group +! - `RWX_O` : read, write, and execute for others +! - `DEFFILEMODE` +! Equivalent to octal `0666` (`rw-rw-rw-`) +! - `ACCESSPERMS` +! Equivalent to octal `0777` (`rwxrwxrwx`) +! +! To grant only the user read, write, and execute permissions, while +! denying all permissions to group members and others, any of the +! following `mkdir()` calls may be used equivalently: +! +! - `ierr = mkdir("mydir", IANY([R_USR, W_USR, X_USR]))` +! - `ierr = mkdir("mydir", RWX_U)` +! +! To grant full permissions to all users (mode `0777`, `rwxrwxrwx`), +! any of the following calls may be used equivalently: +! +! - `ierr = mkdir("mydir", IANY([R_USR, W_USR, X_USR, R_GRP, W_GRP, X_GRP, & +! R_OTH, W_OTH, X_OTH]))` +! - `ierr = mkdir("mydir", IANY([RWX_U, RWX_G, RWX_O]))` +! - `ierr = mkdir("mydir", ACCESSPERMS)` +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Mkdir_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_mkdir(dirname, mode) RESULT(ierr) + MODULE FUNCTION System_Mkdir(dirname, mode) RESULT(ierr) CHARACTER(len=*), INTENT(in) :: dirname INTEGER, INTENT(in) :: mode INTEGER :: ierr - END FUNCTION system_mkdir + END FUNCTION System_Mkdir END INTERFACE !---------------------------------------------------------------------------- -! +! System_Opendir@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_opendir(3f) - [M_system:QUERY_FILE] open directory stream by calling opendir(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_opendir(dirname,dir,ierr) -!! -!! character(len=*), intent(in) :: dirname -!! type(c_ptr) :: dir -!! integer,intent(out) :: ierr -!! -!!##DESCRIPTION -!! The system_opendir(3f) procedure opens a directory stream -!! corresponding to the directory named by the dirname argument. -!! The directory stream is positioned at the first entry. -!! -!!##RETURN VALUE -!! Upon successful completion, a pointer to a C dir type is returned. -!! Otherwise, these functions shall return a null pointer and set -!! IERR to indicate the error. -!! -!!##ERRORS -!! -!! An error corresponds to a condition described in opendir(3c): -!! -!! EACCES Search permission is denied for the component of the -!! path prefix of dirname or read permission is denied -!! for dirname. -!! -!! ELOOP A loop exists in symbolic links encountered during -!! resolution of the dirname argument. -!! -!! ENAMETOOLONG The length of a component of a pathname is longer than {NAME_MAX}. -!! -!! ENOENT A component of dirname does not name an existing directory or dirname is an empty string. -!! -!! ENOTDIR A component of dirname names an existing file that is neither a directory nor a symbolic link to a directory. -!! -!! ELOOP More than {SYMLOOP_MAX} symbolic links were encountered during resolution of the dirname argument. -!! -!! EMFILE All file descriptors available to the process are currently open. -!! -!! ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, -!! or pathname resolution of a symbolic link produced an intermediate -!! result with a length that exceeds {PATH_MAX}. -!! -!! ENFILE Too many files are currently open in the system. -!! -!!##APPLICATION USAGE -!! The opendir() function should be used in conjunction with readdir(), closedir(), and rewinddir() to examine the contents -!! of the directory (see the EXAMPLES section in readdir()). This method is recommended for portability. -!!##OPTIONS -!! dirname name of directory to open a directory stream for -!!##RETURNS -!! dir pointer to directory stream. If an -!! error occurred, it will not be associated. -!! ierr 0 indicates no error occurred -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_opendir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_closedir -!! use iso_c_binding -!! implicit none -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: ierr -!! !--- open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! if(ierr.eq.0)then -!! !--- read directory stream -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! endif -!! !--- close directory stream -!! call system_closedir(dir,ierr) -!! end program demo_system_opendir -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain - +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: open directory stream by calling opendir +! +!# System_Opendir +! +! The `system_opendir(3f)` procedure opens a directory stream that +! corresponds to the directory specified by the `dirname` argument. +! +! The directory stream is positioned at the first directory entry. +! +!## Return value +! +! - Upon successful completion, a pointer to a C `DIR` type is returned. +! +! - On failure, a null pointer is returned and `IERR` is set to indicate +! the error condition. +! +!## Errors +! +! Errors correspond to the conditions described for `opendir(3c)`, +! including the following: +! +! - `EACCES` +! Search permission is denied for a component of the path prefix of +! `dirname`, or read permission is denied for `dirname`. +! +! - `ELOOP` +! A loop exists in symbolic links encountered during resolution of +! the `dirname` argument. +! +! - `ENAMETOOLONG` +! The length of a pathname component exceeds `{NAME_MAX}`. +! +! - `ENOENT` +! A component of `dirname` does not name an existing directory, or +! `dirname` is an empty string. +! +! - `ENOTDIR` +! A component of `dirname` names an existing file that is neither a +! directory nor a symbolic link to a directory. +! +! - `ELOOP` +! More than `{SYMLOOP_MAX}` symbolic links were encountered during +! resolution of the `dirname` argument. +! +! - `EMFILE` +! All file descriptors available to the process are currently open. +! +! - `ENAMETOOLONG` +! The length of a pathname exceeds `{PATH_MAX}`, or pathname +! resolution of a symbolic link produced an intermediate result whose +! length exceeds `{PATH_MAX}`. +! +! - `ENFILE` +! Too many files are currently open in the system. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Opendir_test_1.F90" %}} +!``` +! INTERFACE - MODULE SUBROUTINE system_opendir(dirname, dir, ierr) - CHARACTER(len=*), INTENT(in) :: dirname - TYPE(C_PTR) :: dir - INTEGER, INTENT(out) :: ierr - END SUBROUTINE system_opendir + MODULE SUBROUTINE System_Opendir(dirname, dir, ierr) + CHARACTER(len=*), INTENT(IN) :: dirname + !! name of directory to open a directory stream for + TYPE(C_PTR), INTENT(INOUT) :: dir + !! pointer to directory stream. If an + !! error occurred, it will not be associated. + INTEGER, INTENT(OUT) :: ierr + !! ierr 0 indicates no error occurred + END SUBROUTINE System_Opendir END INTERFACE !---------------------------------------------------------------------------- +! System_Readdir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Read a directory ! -!---------------------------------------------------------------------------- -!> -!!##NAME -!! system_readdir(3f) - [M_system:QUERY_FILE] read a directory using readdir(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_readdir(dir,filename,ierr) -!! -!! type(c_ptr),value :: dir -!! character(len=:),intent(out),allocatable :: filename -!! integer,intent(out) :: ierr -!! -!!##DESCRIPTION -!! -!! system_readdir(3f) returns the name of the directory entry at the -!! current position in the directory stream specified by the argument -!! DIR, and positions the directory stream at the next entry. It returns -!! a null name upon reaching the end of the directory stream. -!! -!!##OPTIONS -!! -!! DIR A pointer to the directory opened by system_opendir(3f). -!! -!!##RETURNS -!! -!! FILENAME the name of the directory entry at the current position in -!! the directory stream specified by the argument DIR, and -!! positions the directory stream at the next entry. -!! -!! The readdir() function does not return directory entries -!! containing empty names. If entries for dot or dot-dot exist, -!! one entry is returned for dot and one entry is returned -!! for dot-dot. -!! -!! The entry is marked for update of the last data access -!! timestamp each time it is read. -!! -!! reaching the end of the directory stream, the name is a blank name. -!! -!! IERR If IERR is set to non-zero on return, an error occurred. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_readdir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_rewinddir,system_closedir -!! use iso_c_binding -!! implicit none -!! -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: i, ierr -!! !--- open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! if(ierr.eq.0)then -!! !--- read directory stream twice -!! do i=1,2 -!! write(*,'(a,i0)')'PASS ',i -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! call system_rewinddir(dir) -!! enddo -!! endif -!! !--- close directory stream -!! call system_closedir(dir,ierr) -!! -!! end program demo_system_readdir -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!# System_Readdir +! +! system_readdir(3f) returns the name of the directory entry at the +! current position in the directory stream specified by the argument +! DIR, and positions the directory stream at the next entry. It returns +! a null name upon reaching the end of the directory stream. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Readdir_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_readdir(dir, filename, ierr) + MODULE SUBROUTINE System_Readdir(dir, filename, ierr) TYPE(C_PTR), VALUE :: dir + !! A pointer to the directory opened by system_opendir(3f). CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename + !! the name of the directory entry at the current position in + !! the directory stream specified by the argument DIR, and + !! positions the directory stream at the next entry. + !! The readdir() function does not return directory entries + !! containing empty names. If entries for dot or dot-dot exist, + !! one entry is returned for dot and one entry is returned + !! for dot-dot. + !! The entry is marked for update of the last data access + !! timestamp each time it is read. + !! reaching the end of the directory stream, the name is a blank name. INTEGER, INTENT(out) :: ierr - END SUBROUTINE system_readdir + !! If IERR is set to non-zero on return, an error occurred. + END SUBROUTINE System_Readdir END INTERFACE !---------------------------------------------------------------------------- -! +! System_Rewinddir@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_rewinddir(3f) - [M_system:QUERY_FILE] call rewinddir(3c) to rewind directory stream -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_rewinddir(dir) -!! -!! type(c_ptr),value :: dir -!! -!!##DESCRIPTION -!! Return to pointer to the beginning of the list for a currently open directory list. -!! -!!##OPTIONS -!! DIR A C_pointer assumed to have been allocated by a call to SYSTEM_OPENDIR(3f). -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_rewinddir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_rewinddir,system_closedir -!! use iso_c_binding -!! implicit none -!! -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: i, ierr -!! !>>> open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! !>>> read directory stream twice -!! do i=1,2 -!! write(*,'(a,i0)')'PASS ',i -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! !>>> rewind directory stream -!! call system_rewinddir(dir) -!! enddo -!! !>>> close directory stream -!! call system_closedir(dir,ierr) -!! -!! end program demo_system_rewinddir -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Rewind directory stream +! +!# System_Rewinddir +! +! Return to pointer to the beginning of the list for a currently open +! directory list. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Rewinddir_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_rewinddir(dir) + MODULE SUBROUTINE System_Rewinddir(dir) TYPE(C_PTR), VALUE :: dir - END SUBROUTINE system_rewinddir + !! A C_Pointer assumed to have been allocated by a + !! call to SYSTEM_OPENDIR(3f). + END SUBROUTINE System_Rewinddir END INTERFACE !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_closedir(3f) - [M_system:QUERY_FILE] close a directory stream by calling closedir(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_closedir(dir,ierr) -!! -!! type(c_ptr) :: dir -!! integer,intent(out) :: ierr -!!##DESCRIPTION -!! The SYSTEM_CLOSEDIR(3f) function closes the directory stream referred to by the argument DIR. -!! Upon return, the value of DIR may no longer point to an accessible object. -!!##OPTIONS -!! dir directory stream pointer opened by SYSTEM_OPENDIR(3f). -!! ierr Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0; -!! otherwise, an error has occurred. -!!##ERRORS -!! system_closedir(3f) may fail if: -!! -!! EBADF The dirp argument does not refer to an open directory stream. -!! EINTR The closedir() function was interrupted by a signal. -!!##EXAMPLE -!! -!! Sample program -!! -!! program demo_system_closedir -!! use M_system, only : system_opendir,system_readdir -!! use M_system, only : system_closedir, system_rewinddir -!! use iso_c_binding, only : c_ptr -!! implicit none -!! type(c_ptr) :: dir -!! character(len=:),allocatable :: filename -!! integer :: ierr -!! !--- open directory stream to read from -!! call system_opendir('.',dir,ierr) -!! !--- read directory stream -!! do -!! call system_readdir(dir,filename,ierr) -!! if(filename.eq.' ')exit -!! write(*,*)filename -!! enddo -!! call system_rewinddir(dir) -!! !--- close directory stream -!! call system_closedir(dir,ierr) -!! end program demo_system_closedir -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Close a directory stream by calling closedir +! +!# System_Closedir +! +! The SYSTEM_CLOSEDIR(3f) function closes the directory stream +! referred to by the argument DIR. Upon return, the value of DIR may no +! longer point to an accessible object. +! +! system_closedir(3f) may fail if: +! +!- EBADF: The dirp argument does not refer to an open directory stream. +!- EINTR: The closedir() function was interrupted by a signal. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Closedir_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_closedir(dir, ierr) + MODULE SUBROUTINE System_Closedir(dir, ierr) TYPE(C_PTR), VALUE :: dir + !! directory stream pointer opened by SYSTEM_OPENDIR(3f). INTEGER, INTENT(out), OPTIONAL :: ierr - END SUBROUTINE system_closedir + !! Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0; + !! otherwise, an error has occurred. + END SUBROUTINE System_Closedir END INTERFACE !---------------------------------------------------------------------------- -! +! System_Putenv@EnvironmentMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_putenv(3f) - [M_system:ENVIRONMENT] set environment variable from Fortran by calling putenv(3c) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine system_putenv(string, err) -!! -!! character(len=*),intent(in) :: string -!! integer, optional, intent(out) :: err -!! -!!##DESCRIPTION -!! The system_putenv() function adds or changes the value of environment variables. -!! -!!##OPTIONS -!! string string of format "NAME=value". -!! If name does not already exist in the environment, then string is added to the environment. -!! If name does exist, then the value of name in the environment is changed to value. -!! The string passed to putenv(3c) becomes part of the environment, -!! so this routine creates a string each time it is called that increases the amount of -!! memory the program uses. -!! err The system_putenv() function returns zero on success, or nonzero if an error occurs. -!! A non-zero error usually indicates sufficient memory does not exist to store the -!! variable. -!! -!!##EXAMPLE -!! -!! Sample setting an environment variable from Fortran: -!! -!! program demo_system_putenv -!! use M_system, only : system_putenv -!! use iso_c_binding -!! implicit none -!! integer :: ierr -!! ! -!! write(*,'(a)')'no environment variables containing "GRU":' -!! call execute_command_line('env|grep GRU') -!! ! -!! call system_putenv('GRU=this is the value',ierr) -!! write(*,'(a,i0)')'now "GRU" should be defined: ',ierr -!! call execute_command_line('env|grep GRU') -!! ! -!! call system_putenv('GRU2=this is the second value',ierr) -!! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined: ',ierr -!! call execute_command_line('env|grep GRU') -!! ! -!! call system_putenv('GRU2',ierr) -!! call system_putenv('GRU',ierr) -!! write(*,'(a,i0)')'should be gone, varies with different putenv(3c): ',ierr -!! call execute_command_line('env|grep GRU') -!! write(*,'(a)')'system_unsetenv(3f) is a better way to remove variables' -!! ! -!! end program demo_system_putenv -!! -!! Results: -!! -!! no environment variables containing "GRU": -!! now "GRU" should be defined: 0 -!! GRU=this is the value -!! now "GRU" and "GRU2" should be defined: 0 -!! GRU2=this is the second value -!! GRU=this is the value -!! should be gone, varies with different putenv(3c): 0 -!! system_unsetenv(3f) is a better way to remove variables -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Set environment variable from Fortran +! +!# System_Putenv +! +! The system_putenv() function adds or changes the value +! of environment variables. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Putenv_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_putenv(string, err) + MODULE SUBROUTINE System_Putenv(string, err) CHARACTER(len=*), INTENT(in) :: string + !! string of format "NAME=value". + !! If name does not already exist in the environment, + !! then string is added to the environment. + !! If name does exist, then the value of name in the environment is + !! changed to value. + !! The string passed to putenv(3c) becomes part of the environment, + !! so this routine creates a string each time it is called that + !! increases the amount of + !! memory the program uses. INTEGER, OPTIONAL, INTENT(out) :: err - END SUBROUTINE system_putenv + !! The system_putenv() function returns zero on success, + !! or nonzero if an error occurs. + !! A non-zero error usually indicates sufficient memory + !! does not exist to store the + !! variable. + END SUBROUTINE System_Putenv END INTERFACE !---------------------------------------------------------------------------- -! +! arr2str@UtilityMethods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-07 +! summary: convert fortran array to a string + INTERFACE MODULE PURE FUNCTION arr2str(array) RESULT(string) - CHARACTER(len=1), INTENT(in) :: array(:) + CHARACTER(len=1), INTENT(IN) :: array(:) CHARACTER(len=SIZE(array)) :: string END FUNCTION arr2str END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getenv@EnvironmentMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_getenv(3f) - [M_system:ENVIRONMENT] get environment variable -!! from Fortran by calling get_environment_variable(3f) -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! function system_getenv(name,default) -!! -!! character(len=:),allocatable :: system_getenv -!! character(len=*),intent(in) :: name -!! character(len=*),intent(in),optional :: default -!! -!!##DESCRIPTION -!! The system_getenv() function gets the value of an environment variable. -!! -!!##OPTIONS -!! name Return the value of the specified environment variable or -!! blank if the variable is not defined. -!! default If the value returned would be blank this value will be used -!! instead. -!! -!!##EXAMPLE -!! -!! Sample setting an environment variable from Fortran: -!! -!! program demo_system_getenv -!! use M_system, only : system_getenv -!! implicit none -!! write(*,'("USER : ",a)')system_getenv('USER') -!! write(*,'("LOGNAME : ",a)')system_getenv('LOGNAME') -!! write(*,'("USERNAME : ",a)')system_getenv('USERNAME') -!! end program demo_system_getenv -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: get environment variable +! +!# System_Getenv +! +! The system_getenv() function gets the value of an environment variable. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getenv_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_getenv(name, default) RESULT(VALUE) - CHARACTER(len=*), INTENT(in) :: name - CHARACTER(len=*), INTENT(in), OPTIONAL :: default - INTEGER :: howbig - INTEGER :: stat - CHARACTER(len=:), ALLOCATABLE :: VALUE - END FUNCTION system_getenv + MODULE FUNCTION System_Getenv(name, default) RESULT(VALUE) + CHARACTER(*), INTENT(IN) :: name + !! Return the value of the specified environment variable or + !! blank if the variable is not defined. + CHARACTER(*), INTENT(IN), OPTIONAL :: default + !! If the value returned would be blank this value will be used + !! instead. + CHARACTER(:), ALLOCATABLE :: VALUE + END FUNCTION System_Getenv END INTERFACE !---------------------------------------------------------------------------- -! +! Set_Environment_Variable@EnvironmentMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! set_environment_variable(3f) - [M_system:ENVIRONMENT] call setenv(3c) to set environment variable -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine set_environment_variable(NAME, VALUE, STATUS) -!! -!! character(len=*) :: NAME -!! character(len=*) :: VALUE -!! integer, optional, intent(out) :: STATUS -!! -!!##DESCRIPTION -!! The set_environment_variable() procedure adds or changes the value of environment variables. -!! -!!##OPTIONS -!! NAME If name does not already exist in the environment, then string is added to the environment. -!! If name does exist, then the value of name in the environment is changed to value. -!! VALUE Value to assign to environment variable NAME -!! STATUS returns zero on success, or nonzero if an error occurs. -!! A non-zero error usually indicates sufficient memory does not exist to store the -!! variable. -!! -!!##EXAMPLE -!! -!! Sample setting an environment variable from Fortran: -!! -!! program demo_set_environment_variable -!! use M_system, only : set_environment_variable -!! use iso_c_binding -!! implicit none -!! integer :: ierr -!! !! -!! write(*,'(a)')'no environment variables containing "GRU":' -!! call execute_command_line('env|grep GRU') -!! !! -!! call set_environment_variable('GRU','this is the value',ierr) -!! write(*,'(a,i0)')'now "GRU" should be defined, status=',ierr -!! call execute_command_line('env|grep GRU') -!! !! -!! call set_environment_variable('GRU2','this is the second value',ierr) -!! write(*,'(a,i0)')'now "GRU" and "GRU2" should be defined, status =',ierr -!! !! -!! call execute_command_line('env|grep GRU') -!! end program demo_set_environment_variable -!! -!! Results: -!! -!! no environment variables containing "GRU": -!! now "GRU" should be defined, status=0 -!! GRU=this is the value -!! now "GRU" and "GRU2" should be defined, status =0 -!! GRU2=this is the second value -!! GRU=this is the value -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: call setenv(3c) to set environment variable +! +!# Set_Environment +! +! The set_environment_variable() procedure adds or changes the value of +! environment variables. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/Set_Environment_Variable_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE set_environment_variable(NAME, VALUE, STATUS) - CHARACTER(len=*) :: NAME - CHARACTER(len=*) :: VALUE - INTEGER, OPTIONAL, INTENT(out) :: STATUS - END SUBROUTINE set_environment_variable + MODULE SUBROUTINE Set_Environment_Variable(NAME, VALUE, STATUS) + CHARACTER(*), INTENT(IN) :: NAME + !! If name does not already exist in the environment, + !! then string is added to the environment. + !! If name does exist, then the value of name in the environment + !! is changed to value. + CHARACTER(*), INTENT(IN) :: VALUE + !! Value to assign to environment variable NAME + INTEGER, OPTIONAL, INTENT(OUT) :: STATUS + !! returns zero on success, or nonzero if an error occurs. + !! A non-zero error usually indicates sufficient memory does + !! not exist to store the + !! variable. + END SUBROUTINE Set_Environment_Variable END INTERFACE !---------------------------------------------------------------------------- -! +! System_Clearenv@EnvironmentMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_clearenv(3f) - [M_system:ENVIRONMENT] clear environment by calling clearenv(3c) -!! (LICENSE:PD) -!! -!! -!!##SYNOPSIS -!! -!! subroutine system_clearenv(ierr) -!! -!! integer,intent(out),optional :: ierr -!! -!!##DESCRIPTION -!! The clearenv() procedure clears the environment of all name-value -!! pairs. Typically used in security-conscious applications or ones where -!! configuration control requires ensuring specific variables are set. -!! -!!##RETURN VALUES -!! ierr returns zero on success, and a nonzero value on failure. Optional. -!! If not present and an error occurs the program stops. -!! -!!##EXAMPLE -!! -!! -!! Sample program: -!! -!! program demo_system_clearenv -!! use M_system, only : system_clearenv -!! implicit none -!! ! environment before clearing -!! call execute_command_line('env|wc') -!! ! environment after clearing (not necessarily blank!!) -!! call system_clearenv() -!! call execute_command_line('env') -!! end program demo_system_clearenv -!! -!! Typical output: -!! -!! 89 153 7427 -!! PWD=/home/urbanjs/V600 -!! SHLVL=1 -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Clear environment by calling clearenv(3c) +! +!# System_Clearenv +! +! The System_Clearenv() procedure clears the environment of all name-value +! pairs. Typically used in security-conscious applications or ones where +! configuration control requires ensuring specific variables are set. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Clearenv_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_clearenv(ierr) - INTEGER, INTENT(out), OPTIONAL :: ierr - END SUBROUTINE system_clearenv + MODULE SUBROUTINE System_Clearenv(ierr) + INTEGER, INTENT(OUT), OPTIONAL :: ierr + !! returns zero on success, and a nonzero value on failure. Optional. + !! If not present and an error occurs the program stops. + END SUBROUTINE System_Clearenv END INTERFACE !---------------------------------------------------------------------------- -! +! System_Unsetenv@EnvironmentMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_unsetenv(3f) - [M_system:ENVIRONMENT] delete an environment variable by calling unsetenv(3c) -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_unsetenv(name,ierr) -!! -!! character(len=*),intent(in) :: name -!! integer,intent(out),optional :: ierr -!! -!!##DESCRIPTION -!! -!! The system_unsetenv(3f) function deletes the variable name from the -!! environment. -!! -!!##OPTIONS -!! name name of variable to delete. -!! If name does not exist in the environment, then the -!! function succeeds, and the environment is unchanged. -!! -!! ierr The system_unsetenv(3f) function returns zero on success, or -1 on error. -!! name is NULL, points to a string of length 0, or contains an '=' character. -!! Insufficient memory to add a new variable to the environment. -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_unsetenv -!! use M_system, only : system_unsetenv, system_putenv -!! implicit none -!! call system_putenv('GRU=this is the value') -!! write(*,'(a)')'The variable GRU should be set' -!! call execute_command_line('env|grep GRU') -!! call system_unsetenv('GRU') -!! write(*,'(a)')'The variable GRU should not be set' -!! call execute_command_line('env|grep GRU') -!! end program demo_system_unsetenv -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: delete an environment variable by calling unsetenv(3c) +! +!# System_Unsetenv +! +! The System_Unsetenv(3f) function deletes the variable name from the +! environment. INTERFACE - MODULE SUBROUTINE system_unsetenv(name, ierr) + MODULE SUBROUTINE System_Unsetenv(name, ierr) CHARACTER(len=*), INTENT(in) :: name + !! name of variable to delete. + !! If name does not exist in the environment, then the + !! function succeeds, and the environment is unchanged. INTEGER, INTENT(out), OPTIONAL :: ierr - END SUBROUTINE system_unsetenv + !! The system_unsetenv(3f) function returns zero on success, + !! or -1 on error. + !! name is NULL, points to a string of length 0, or + !! contains an '=' character. + !! Insufficient memory to add a new variable to the environment. + END SUBROUTINE System_Unsetenv END INTERFACE !---------------------------------------------------------------------------- -! +! System_Readenv@EnvironmentMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_readenv(3f) - [M_system:ENVIRONMENT] step thru and read environment table -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! function system_readenv() result(string) -!! -!! character(len=:),allocatable :: string -!!##DESCRIPTION -!! A simple interface allows reading the environment variable table of the process. Call -!! system_initenv(3f) to initialize reading the environment table, then call system_readenv(3f) can -!! be called until a blank line is returned. If more than one thread -!! reads the environment or the environment is changed while being read the results are undefined. -!!##OPTIONS -!! string the string returned from the environment of the form "NAME=VALUE" -!! -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_readenv -!! use M_system, only : system_initenv, system_readenv -!! character(len=:),allocatable :: string -!! call system_initenv() -!! do -!! string=system_readenv() -!! if(string.eq.'')then -!! exit -!! else -!! write(*,'(a)')string -!! endif -!! enddo -!! end program demo_system_readenv -!! -!! Sample results: -!! -!! USERDOMAIN_ROAMINGPROFILE=buzz -!! HOMEPATH=\Users\JSU -!! APPDATA=C:\Users\JSU\AppData\Roaming -!! MANPATH=/home/urbanjs/V600/LIBRARY/libGPF/download/tmp/man:/home/urbanjs/V600/doc/man::: -!! DISPLAYNUM=0 -!! ProgramW6432=C:\Program Files -!! HOSTNAME=buzz -!! XKEYSYMDB=/usr/share/X11/XKeysymDB -!! PUBLISH_CMD= -!! OnlineServices=Online Services -!! : -!! : -!! : -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: step thru and read environment table +! +! ## System_Readenv +! +! This routine provides a simple interface for reading the environment +! variable table of the current process. +! +! The recommended usage pattern is as follows: +! +! - Call `system_initenv(3f)` to initialize access to the environment +! table. +! +! - Repeatedly call `system_readenv(3f)` to read entries from the +! environment table. +! +! - Reading terminates when a blank line is returned. +! +! ### Notes +! +! - If more than one thread reads the environment simultaneously, the +! results are undefined. +! +! - If the environment is modified while it is being read, the results +! are also undefined. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Readenv_test_1.F90" %}} +!``` INTERFACE - MODULE FUNCTION system_readenv() RESULT(string) + MODULE FUNCTION System_Readenv() RESULT(string) CHARACTER(len=:), ALLOCATABLE :: string - END FUNCTION system_readenv + !! the string returned from the environment of the form "NAME=VALUE" + END FUNCTION System_Readenv END INTERFACE !---------------------------------------------------------------------------- -! +! Fileglob@FileMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! fileglob(3f) - [M_system:QUERY_FILE] Read output of an ls(1) command from Fortran -!! (LICENSE:PD) -!! -!!##SYNOPSIS -!! -!! subroutine fileglob(glob,list) -!! -!! character(len=*),intent(in) :: glob -!! character(len=*),pointer :: list(:) -!! -!!##DESCRIPTION -!! Non-portable procedure uses the shell and the ls(1) command to expand a filename -!! and returns a pointer to a list of expanded filenames. -!! -!!##OPTIONS -!! glob Pattern for the filenames (like: *.txt) -!! list Allocated list of filenames (returned), the caller must deallocate it. -!! -!!##EXAMPLE -!! -!! Read output of an ls(1) command from Fortran -!! -!! program demo_fileglob ! simple unit test -!! call tryit('*.*') -!! call tryit('/tmp/__notthere.txt') -!! contains -!! -!! subroutine tryit(string) -!! use M_system, only : fileglob -!! character(len=255),pointer :: list(:) -!! character(len=*) :: string -!! call fileglob(string, list) -!! write(*,*)'Files:',size(list) -!! write(*,'(a)')(trim(list(i)),i=1,size(list)) -!! deallocate(list) -!! end subroutine tryit -!! -!! end program demo_fileglob ! simple unit test -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Read output of an ls(1) command from Fortran +! +!# Fileglob +! +! Non-portable procedure uses the shell and the ls(1) command +! to expand a filename +! and returns a pointer to a list of expanded filenames. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/Fileglob_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE fileglob(glob, list) - CHARACTER(len=*), INTENT(in) :: glob + MODULE SUBROUTINE Fileglob(glob, list) + CHARACTER(*), INTENT(IN) :: glob !! Pattern for the filenames (like: *.txt) - CHARACTER(len=*), POINTER :: list(:) + CHARACTER(*), POINTER, INTENT(INOUT) :: list(:) !! Allocated list of filenames (returned), the caller must deallocate it. - END SUBROUTINE fileglob + END SUBROUTINE Fileglob END INTERFACE !---------------------------------------------------------------------------- -! +! System_Getuname@GetMethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_uname(3f) - [M_system] call a C wrapper that calls uname(3c) to get current system information from Fortran -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_uname(WHICH,NAMEOUT) -!! -!! character(KIND=C_CHAR),intent(in) :: WHICH -!! character(len=*),intent(out) :: NAMEOUT -!!##DESCRIPTION -!! Given a letter, return a corresponding description of the current operating system. -!! The NAMEOUT variable is assumed sufficiently large enough to hold the value. -!! -!! s return the kernel name -!! r return the kernel release -!! v return the kernel version -!! n return the network node hostname -!! m return the machine hardware name -!! T test mode -- print all information, in the following order - srvnm -!! -!!##EXAMPLE -!! -!! Call uname(3c) from Fortran -!! -!! program demo_system_uname -!! use M_system, only : system_uname -!! implicit none -!! integer,parameter :: is=100 -!! integer :: i -!! character(len=*),parameter :: letters='srvnmxT' -!! character(len=is) :: string=' ' -!! -!! do i=1,len(letters) -!! write(*,'(80("="))') -!! call system_uname(letters(i:i),string) -!! write(*,*)'=====> TESTING system_uname('//letters(i:i)//')--->'//trim(string) -!! enddo -!! -!! end program demo_system_uname -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get current system information +! +! ## System_Getuname +! +! Given a single-character selector, this routine returns the corresponding +! description of the current operating system. +! +! The `NAMEOUT` variable is assumed to be sufficiently large to hold the +! returned value. +! +! The following selector values are supported: +! +! - `s` Returns the kernel name. +! - `r` Returns the kernel release. +! - `v` Returns the kernel version. +! - `n` Returns the network node hostname. +! - `m` Returns the machine hardware name. +! - `T` Test mode: prints all information in the following order: +! `s r v n m`. INTERFACE - MODULE SUBROUTINE system_uname(WHICH, NAMEOUT) - CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH - CHARACTER(len=*), INTENT(out) :: NAMEOUT - END SUBROUTINE system_uname + MODULE SUBROUTINE System_Uname(WHICH, NAMEOUT) + CHARACTER(KIND=C_CHAR), INTENT(IN) :: WHICH + CHARACTER(*), INTENT(OUT) :: NAMEOUT + END SUBROUTINE System_Uname END INTERFACE !---------------------------------------------------------------------------- -! +! System_Gethostname@Getmethods !---------------------------------------------------------------------------- -!> -!!##NAME -!! system_gethostname(3f) - [M_system:QUERY] get name of current host -!! (LICENSE:PD) -!!##SYNOPSIS -!! -!! subroutine system_gethostname(string,ierr) -!! -!! character(len=:),allocatable,intent(out) :: NAME -!! integer,intent(out) :: IERR -!!##DESCRIPTION -!! The system_gethostname(3f) procedure returns the standard host -!! name for the current machine. -!! -!!##OPTIONS -!! string returns the hostname. Must be an allocatable CHARACTER variable. -!! ierr Upon successful completion, 0 shall be returned; otherwise, -1 -!! shall be returned. -!!##EXAMPLE -!! -!! Sample program: -!! -!! program demo_system_gethostname -!! use M_system, only : system_gethostname -!! implicit none -!! character(len=:),allocatable :: name -!! integer :: ierr -!! call system_gethostname(name,ierr) -!! if(ierr.eq.0)then -!! write(*,'("hostname[",a,"]")')name -!! else -!! write(*,'(a)')'ERROR: could not get hostname' -!! endif -!! end program demo_system_gethostname -!! -!!##AUTHOR -!! John S. Urban -!!##LICENSE -!! Public Domain +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get name of current host +! +!# System_Gethostname +! +! The system_gethostname(3f) procedure returns the standard host +! name for the current machine. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Gethostname_test_1.F90" %}} +!``` INTERFACE - MODULE SUBROUTINE system_gethostname(NAME, IERR) - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: NAME - INTEGER, INTENT(out) :: IERR - END SUBROUTINE system_gethostname + MODULE SUBROUTINE System_Gethostname(NAME, IERR) + CHARACTER(:), ALLOCATABLE, INTENT(OUT) :: NAME + !! string returns the hostname. + INTEGER, INTENT(OUT) :: IERR + !! Upon successful completion, 0 shall be returned; otherwise, -1 + !! shall be returned. + END SUBROUTINE System_Gethostname END INTERFACE !---------------------------------------------------------------------------- @@ -3307,6 +2106,12 @@ END SUBROUTINE system_gethostname ! ! - `system_getlogin()` ! Returns the name associated with the current login activity.!! +!! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getlogin_test_1.F90" %}} +!``` INTERFACE MODULE FUNCTION System_Getlogin() RESULT(fname) @@ -3365,7 +2170,7 @@ END FUNCTION System_Perm INTERFACE MODULE FUNCTION System_Getgrgid(gid) RESULT(gname) - CLASS(*), INTENT(in) :: gid + CLASS(*), INTENT(IN) :: gid !! GID to try to look up associated group for. Can be of any !! INTEGER type. CHARACTER(len=:), ALLOCATABLE :: gname @@ -3396,10 +2201,10 @@ END FUNCTION System_Getgrgid INTERFACE MODULE FUNCTION System_Getpwuid(uid) RESULT(uname) - CLASS(*), INTENT(in) :: uid + CLASS(*), INTENT(IN) :: uid !! UID to try to look up associated username for. Can be of any !! INTEGER type. - CHARACTER(len=:), ALLOCATABLE :: uname + CHARACTER(:), ALLOCATABLE :: uname !! returns the login name. END FUNCTION System_Getpwuid END INTERFACE @@ -3448,10 +2253,10 @@ END FUNCTION System_Getpwuid INTERFACE MODULE SUBROUTINE System_Stat(pathname, values, ierr) - CHARACTER(len=*), INTENT(IN) :: pathname + CHARACTER(*), INTENT(IN) :: pathname !! The type shall be CHARACTER, of the default kind and a valid !! path within the file system. - INTEGER(kind=INT64), INTENT(OUT) :: values(13) + INTEGER(INT64), INTENT(OUT) :: values(13) !! VALUES The type shall be INTEGER(8), DIMENSION(13). INTEGER, OPTIONAL, INTENT(OUT) :: ierr END SUBROUTINE System_Stat @@ -3497,9 +2302,9 @@ END FUNCTION System_Dir INTERFACE MODULE FUNCTION Matchw(tame, wild) LOGICAL :: Matchw - CHARACTER(len=*) :: tame + CHARACTER(*), INTENT(IN) :: tame !! A string without wildcards - CHARACTER(len=*) :: wild + CHARACTER(*), INTENT(IN) :: wild !! A (potentially) corresponding string with wildcards END FUNCTION Matchw END INTERFACE diff --git a/src/submodules/System/src/System_Method@EnquiryMethods.F90 b/src/submodules/System/src/System_Method@EnquiryMethods.F90 index eb60ebebb..4baa561d4 100644 --- a/src/submodules/System/src/System_Method@EnquiryMethods.F90 +++ b/src/submodules/System/src/System_Method@EnquiryMethods.F90 @@ -16,6 +16,9 @@ ! along with this program. If not, see SUBMODULE(System_Method) EnquiryMethods +USE ISO_C_BINDING, ONLY: C_SIZE_T +USE ISO_C_BINDING, ONLY: C_ASSOCIATED + IMPLICIT NONE CONTAINS diff --git a/src/submodules/System/src/System_Method@EnviormentMethods.F90 b/src/submodules/System/src/System_Method@EnviormentMethods.F90 deleted file mode 100644 index 49ee3ad2e..000000000 --- a/src/submodules/System/src/System_Method@EnviormentMethods.F90 +++ /dev/null @@ -1,180 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! -SUBMODULE(System_Method) EnvironmentMethods -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_putenv -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_string(*) - END FUNCTION -END INTERFACE - -INTEGER :: loc_err -INTEGER :: i - -! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit -CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) - -ALLOCATE (memleak(LEN(string) + 1)) -DO i = 1, LEN(string) - memleak(i) = string(i:i) -END DO -memleak(LEN(string) + 1) = C_NULL_CHAR - -loc_err = c_putenv(memleak) -IF (PRESENT(err)) err = loc_err -END PROCEDURE system_putenv - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_getenv -INTEGER :: howbig -INTEGER :: stat - -IF (NAME .NE. '') THEN - call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value - IF (howbig .NE. 0) THEN - SELECT CASE (stat) - CASE (1) - ! print *, NAME, " is not defined in the environment. Strange..." - VALUE = '' - CASE (2) - ! print *, "This processor doesn't support environment variables. Boooh!" - VALUE = '' - CASE default - ! make string to hold value of sufficient size and get value - IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) - ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) - CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) - IF (stat .NE. 0) VALUE = '' - END SELECT - ELSE - VALUE = '' - END IF -ELSE - VALUE = '' -END IF -IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default -END PROCEDURE system_getenv - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE set_environment_variable -INTEGER :: loc_err - -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_name(*) - CHARACTER(kind=C_CHAR) :: c_VALUE(*) - END FUNCTION -END INTERFACE - -loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) -IF (PRESENT(STATUS)) STATUS = loc_err - -END PROCEDURE set_environment_variable - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_clearenv -! emulating because not available on some platforms -CHARACTER(len=:), ALLOCATABLE :: string -INTEGER :: ierr_local1, ierr_local2 - -ierr_local2 = 0 - -INFINITE: DO - CALL system_initenv() - ! important -- changing table causes undefined behavior - ! so reset after each unsetenv - string = system_readenv() - ! get first name=value pair - IF (string .EQ. '') EXIT INFINITE - CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair - IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 -END DO INFINITE - -IF (PRESENT(ierr)) THEN - ierr = ierr_local2 -ELSEIF (ierr_local2 .NE. 0) THEN -! if error occurs and not being returned, stop - WRITE (*, *) '*system_clearenv* error=', ierr_local2 - STOP -END IF -END PROCEDURE system_clearenv - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_unsetenv -INTEGER :: ierr_local - -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") - IMPORT C_INT, C_CHAR - CHARACTER(len=1, kind=C_CHAR) :: c_name(*) - END FUNCTION -END INTERFACE - -ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) - -IF (PRESENT(ierr)) THEN - ierr = ierr_local -ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop - WRITE (*, *) '*system_unsetenv* error=', ierr_local - STOP -END IF - -END PROCEDURE system_unsetenv - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_readenv -CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) - -INTERFACE - SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') - IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T - CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) - END SUBROUTINE c_readenv -END INTERFACE - -c_buff = ' ' -c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR -CALL c_readenv(c_buff) -string = TRIM(arr2str(c_buff)) -END PROCEDURE system_readenv - -END SUBMODULE EnvironmentMethods diff --git a/src/submodules/System/src/System_Method@EnvironmentMethods.F90 b/src/submodules/System/src/System_Method@EnvironmentMethods.F90 index 8126207b4..04c2b5e9e 100644 --- a/src/submodules/System/src/System_Method@EnvironmentMethods.F90 +++ b/src/submodules/System/src/System_Method@EnvironmentMethods.F90 @@ -16,7 +16,9 @@ ! along with this program. If not, see ! SUBMODULE(System_Method) EnvironmentMethods +USE ISO_C_BINDING, ONLY: C_SIZE_T IMPLICIT NONE + CONTAINS !---------------------------------------------------------------------------- @@ -47,4 +49,134 @@ INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") IF (PRESENT(err)) err = loc_err END PROCEDURE system_putenv +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_getenv +INTEGER :: howbig +INTEGER :: stat + +IF (NAME .NE. '') THEN + call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value + IF (howbig .NE. 0) THEN + SELECT CASE (stat) + CASE (1) + ! print *, NAME, " is not defined in the environment. Strange..." + VALUE = '' + CASE (2) + ! print *, "This processor doesn't support environment variables. Boooh!" + VALUE = '' + CASE default + ! make string to hold value of sufficient size and get value + IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) + ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) + CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) + IF (stat .NE. 0) VALUE = '' + END SELECT + ELSE + VALUE = '' + END IF +ELSE + VALUE = '' +END IF +IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default +END PROCEDURE system_getenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE set_environment_variable +INTEGER :: loc_err + +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: c_name(*) + CHARACTER(kind=C_CHAR) :: c_VALUE(*) + END FUNCTION +END INTERFACE + +loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) +IF (PRESENT(STATUS)) STATUS = loc_err + +END PROCEDURE set_environment_variable + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_clearenv +! emulating because not available on some platforms +CHARACTER(len=:), ALLOCATABLE :: string +INTEGER :: ierr_local1, ierr_local2 + +ierr_local2 = 0 + +INFINITE: DO + CALL system_initenv() + ! important -- changing table causes undefined behavior + ! so reset after each unsetenv + string = system_readenv() + ! get first name=value pair + IF (string .EQ. '') EXIT INFINITE + CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair + IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 +END DO INFINITE + +IF (PRESENT(ierr)) THEN + ierr = ierr_local2 +ELSEIF (ierr_local2 .NE. 0) THEN +! if error occurs and not being returned, stop + WRITE (*, *) '*system_clearenv* error=', ierr_local2 + STOP +END IF +END PROCEDURE system_clearenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_unsetenv +INTEGER :: ierr_local + +INTERFACE + INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") + IMPORT C_INT, C_CHAR + CHARACTER(len=1, kind=C_CHAR) :: c_name(*) + END FUNCTION +END INTERFACE + +ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) + +IF (PRESENT(ierr)) THEN + ierr = ierr_local +ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop + WRITE (*, *) '*system_unsetenv* error=', ierr_local + STOP +END IF + +END PROCEDURE system_unsetenv + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_readenv +CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) + +INTERFACE + SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') + IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T + CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) + END SUBROUTINE c_readenv +END INTERFACE + +c_buff = ' ' +c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR +CALL c_readenv(c_buff) +string = TRIM(arr2str(c_buff)) +END PROCEDURE system_readenv + END SUBMODULE EnvironmentMethods diff --git a/src/submodules/System/src/System_Method@FileMethods.F90 b/src/submodules/System/src/System_Method@FileMethods.F90 index 95ed5989f..2aaac85ac 100644 --- a/src/submodules/System/src/System_Method@FileMethods.F90 +++ b/src/submodules/System/src/System_Method@FileMethods.F90 @@ -17,6 +17,7 @@ ! SUBMODULE(System_Method) FileMethods +USE ISO_C_BINDING, ONLY: C_ASSOCIATED IMPLICIT NONE CONTAINS @@ -408,6 +409,52 @@ END FUNCTION c_closedir CALL system_closedir(dir, ierr) !--- close directory stream END PROCEDURE system_dir +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_link +INTEGER(kind=C_INT) :: c_ierr + +INTERFACE + FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_link +END INTERFACE + +c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) +ierr = c_ierr +END PROCEDURE system_link + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_unlink +INTERFACE + FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION c_unlink +END INTERFACE +ierr = c_unlink(str2_carr(TRIM(fname))) +END PROCEDURE system_unlink + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE system_setumask +INTEGER(kind=C_INT) :: umask_c +umask_c = umask_value +old_umask = system_umask(umask_c) +! set current umask +END PROCEDURE system_setumask + !---------------------------------------------------------------------------- ! Include Error !---------------------------------------------------------------------------- diff --git a/src/submodules/System/src/System_Method@GetMethods.F90 b/src/submodules/System/src/System_Method@GetMethods.F90 index 27244ce72..b3723fea4 100644 --- a/src/submodules/System/src/System_Method@GetMethods.F90 +++ b/src/submodules/System/src/System_Method@GetMethods.F90 @@ -17,6 +17,9 @@ SUBMODULE(System_Method) GetMethods USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT +USE ISO_C_BINDING, ONLY: C_LONG_LONG +USE ISO_C_BINDING, ONLY: C_SIZE_T +USE ISO_C_BINDING, ONLY: C_ASSOCIATED IMPLICIT NONE CONTAINS @@ -44,51 +47,6 @@ END SUBROUTINE c_cpu_time ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_link -INTEGER(kind=C_INT) :: c_ierr - -INTERFACE - FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_link -END INTERFACE - -c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) -ierr = c_ierr -END PROCEDURE system_link - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_unlink -INTERFACE - FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_unlink -END INTERFACE -ierr = c_unlink(str2_carr(TRIM(fname))) -END PROCEDURE system_unlink - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_setumask -INTEGER(kind=C_INT) :: umask_c -umask_c = umask_value -old_umask = system_umask(umask_c) ! set current umask -END PROCEDURE system_setumask - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - MODULE PROCEDURE system_getumask INTEGER :: idum INTEGER(kind=C_INT) :: old_umask diff --git a/src/submodules/System/src/System_Method@SignalMethods.F90 b/src/submodules/System/src/System_Method@SignalMethods.F90 index 3fb9e8b66..c7a6c2773 100644 --- a/src/submodules/System/src/System_Method@SignalMethods.F90 +++ b/src/submodules/System/src/System_Method@SignalMethods.F90 @@ -16,6 +16,8 @@ ! along with this program. If not, see SUBMODULE(System_Method) SignalMethods +USE ISO_C_BINDING, ONLY: C_FUNLOC + IMPLICIT NONE CONTAINS diff --git a/src/submodules/System/src/System_Method@UtilityMethods.F90 b/src/submodules/System/src/System_Method@UtilityMethods.F90 index 3f8cf26ce..1cc494b38 100644 --- a/src/submodules/System/src/System_Method@UtilityMethods.F90 +++ b/src/submodules/System/src/System_Method@UtilityMethods.F90 @@ -73,15 +73,15 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE timestamp +MODULE PROCEDURE Timestamp epoch = C_Time(INT(0, kind=8)) -END PROCEDURE timestamp +END PROCEDURE Timestamp !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE arr2str +MODULE PROCEDURE Arr2Str INTEGER :: i string = ' ' @@ -92,13 +92,13 @@ string(i:i) = array(i) END IF END DO -END PROCEDURE arr2str +END PROCEDURE Arr2Str !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE matchw +MODULE PROCEDURE Matchw CHARACTER(len=LEN(tame) + 1) :: tametext CHARACTER(len=LEN(wild) + 1) :: wildtext CHARACTER(len=1), PARAMETER :: NULL = CHAR(0) @@ -106,7 +106,8 @@ CHARACTER(len=:), ALLOCATABLE :: tbookmark, wbookmark ! These two values are set when we observe a wildcard character. They -! represent the locations, in the two strings, from which we start once we've observed it. +! represent the locations, in the two strings, from which we start once +! we've observed it. tametext = tame//NULL wildtext = wild//NULL tbookmark = NULL @@ -114,17 +115,21 @@ wlen = LEN(wild) wi = 1 ti = 1 -DO ! Walk the text strings one character at a time. - IF (wildtext(wi:wi) == '*') THEN ! How do you match a unique text string? - DO i = wi, wlen ! Easy: unique up on it! +DO +! Walk the text strings one character at a time. + IF (wildtext(wi:wi) == '*') THEN + ! How do you match a unique text string? + DO i = wi, wlen + ! Easy: unique up on it! IF (wildtext(wi:wi) .EQ. '*') THEN wi = wi + 1 ELSE EXIT END IF END DO - IF (wildtext(wi:wi) .EQ. NULL) THEN ! "x" matches "*" - matchw = .TRUE. + IF (wildtext(wi:wi) .EQ. NULL) THEN + ! "x" matches "*" + Matchw = .TRUE. RETURN END IF IF (wildtext(wi:wi) .NE. '?') THEN @@ -132,18 +137,21 @@ DO WHILE (tametext(ti:ti) .NE. wildtext(wi:wi)) ti = ti + 1 IF (tametext(ti:ti) .EQ. NULL) THEN - matchw = .FALSE. - RETURN ! "x" doesn't match "*y*" + Matchw = .FALSE. + RETURN + ! "x" doesn't match "*y*" END IF END DO END IF wbookmark = wildtext(wi:) tbookmark = tametext(ti:) - elseif(tametext(ti:ti) .ne. wildtext(wi:wi) .and. wildtext(wi:wi) .ne. '?') then - ! Got a non-match. If we've set our bookmarks, back up to one or both of them and retry. + ELSEIF ((tametext(ti:ti) .NE. wildtext(wi:wi)) & + .AND. (wildtext(wi:wi) .NE. '?')) THEN + ! Got a non-match. If we've set our bookmarks, + ! back up to one or both of them and retry. IF (wbookmark .NE. NULL) THEN IF (wildtext(wi:) .NE. wbookmark) THEN - wildtext = wbookmark; + wildtext = wbookmark wlen = LEN_TRIM(wbookmark) wi = 1 ! Don't go this far back again. @@ -151,53 +159,65 @@ tbookmark = tbookmark(2:) tametext = tbookmark ti = 1 - CYCLE ! "xy" matches "*y" + CYCLE + ! "xy" matches "*y" ELSE wi = wi + 1 END IF END IF IF (tametext(ti:ti) .NE. NULL) THEN ti = ti + 1 - CYCLE ! "mississippi" matches "*sip*" + CYCLE + ! "mississippi" matches "*sip*" END IF END IF - matchw = .FALSE. - RETURN ! "xy" doesn't match "x" + Matchw = .FALSE. + RETURN + ! "xy" doesn't match "x" END IF ti = ti + 1 wi = wi + 1 - IF (tametext(ti:ti) .EQ. NULL) THEN ! How do you match a tame text string? + IF (tametext(ti:ti) .EQ. NULL) THEN + ! How do you match a tame text string? IF (wildtext(wi:wi) .NE. NULL) THEN - DO WHILE (wildtext(wi:wi) == '*') ! The tame way: unique up on it! - wi = wi + 1 ! "x" matches "x*" + DO WHILE (wildtext(wi:wi) == '*') + ! The tame way: unique up on it! + wi = wi + 1 + ! "x" matches "x*" IF (wildtext(wi:wi) .EQ. NULL) EXIT END DO END IF IF (wildtext(wi:wi) .EQ. NULL) THEN - matchw = .TRUE. - RETURN ! "x" matches "x" + Matchw = .TRUE. + RETURN + ! "x" matches "x" END IF - matchw = .FALSE. - RETURN ! "x" doesn't match "xy" + Matchw = .FALSE. + RETURN + ! "x" doesn't match "xy" END IF END DO -END PROCEDURE matchw +END PROCEDURE Matchw !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE anyinteger_to_64bit +MODULE PROCEDURE Anyinteger_to_64bit SELECT TYPE (intin) -TYPE is (INTEGER(kind=INT8)); ii38 = INT(intin, kind=INT64) -TYPE is (INTEGER(kind=INT16)); ii38 = INT(intin, kind=INT64) -TYPE is (INTEGER(kind=INT32)); ii38 = intin -TYPE is (INTEGER(kind=INT64)); ii38 = intin +TYPE IS (INTEGER(kind=INT8)) + ii38 = INT(intin, kind=INT64) +TYPE IS (INTEGER(kind=INT16)) + ii38 = INT(intin, kind=INT64) +TYPE IS (INTEGER(kind=INT32)) + ii38 = intin +TYPE IS (INTEGER(kind=INT64)) + ii38 = intin !class default !write(error_unit,*)'ERROR: unknown integer type' - !stop 'ERROR: *anyinteger_to_64* unknown integer type' + !stop 'ERROR: *Anyinteger_to_64* unknown integer type' END SELECT -END PROCEDURE anyinteger_to_64bit +END PROCEDURE Anyinteger_to_64bit !---------------------------------------------------------------------------- ! From be88f632d9db8c49465ed86de3ff26c7b93ed2d2 Mon Sep 17 00:00:00 2001 From: Vikas Sharma Date: Sun, 8 Feb 2026 16:44:35 +0900 Subject: [PATCH 6/6] Split System module into method-specific files Refactor the System module by extracting method groups into separate Fortran sources and submodules for clarity and maintainability. Added new method files (SystemEnquiry_Method.F90, SystemEnvironment_Method.F90, SystemFile_Method.F90, SystemOptions.F90, SystemProcess_Method.F90, SystemSignal_Method.F90, System_Utility.F90) and updated src/modules/System/CMakeLists.txt to include them. Updated existing interfaces (SystemInterface.F90, System_Method.F90) and adjusted submodule filenames/renames under src/submodules/System (including removal of the old GetMethods file). Also added a .helix/config.toml editor setting to define workspace LSP roots. These changes modularize code originally sourced from M_system into discrete components for easier maintenance and compilation. --- .helix/config.toml | 2 + src/modules/System/CMakeLists.txt | 11 +- .../System/src/SystemEnquiry_Method.F90 | 293 ++ .../System/src/SystemEnvironment_Method.F90 | 258 ++ src/modules/System/src/SystemFile_Method.F90 | 1079 ++++++++ src/modules/System/src/SystemInterface.F90 | 358 ++- src/modules/System/src/SystemOptions.F90 | 105 + .../System/src/SystemProcess_Method.F90 | 399 +++ .../System/src/SystemSignal_Method.F90 | 127 + src/modules/System/src/System_Method.F90 | 2359 +---------------- src/modules/System/src/System_Utility.F90 | 142 + src/submodules/System/CMakeLists.txt | 14 +- ...s.F90 => SystemEnquiry_Method@Methods.F90} | 152 +- ...0 => SystemEnvironment_Method@Methods.F90} | 134 +- ...hods.F90 => SystemFile_Method@Methods.F90} | 199 +- .../src/SystemProcess_Method@Methods.F90 | 198 ++ ...ds.F90 => SystemSignal_Method@Methods.F90} | 20 +- .../System/src/System_Method@GetMethods.F90 | 260 -- ...Methods.F90 => System_Utility@Methods.F90} | 46 +- 19 files changed, 3251 insertions(+), 2905 deletions(-) create mode 100644 .helix/config.toml create mode 100755 src/modules/System/src/SystemEnquiry_Method.F90 create mode 100755 src/modules/System/src/SystemEnvironment_Method.F90 create mode 100755 src/modules/System/src/SystemFile_Method.F90 create mode 100755 src/modules/System/src/SystemOptions.F90 create mode 100755 src/modules/System/src/SystemProcess_Method.F90 create mode 100755 src/modules/System/src/SystemSignal_Method.F90 create mode 100755 src/modules/System/src/System_Utility.F90 rename src/submodules/System/src/{System_Method@EnquiryMethods.F90 => SystemEnquiry_Method@Methods.F90} (51%) rename src/submodules/System/src/{System_Method@EnvironmentMethods.F90 => SystemEnvironment_Method@Methods.F90} (56%) rename src/submodules/System/src/{System_Method@FileMethods.F90 => SystemFile_Method@Methods.F90} (79%) create mode 100644 src/submodules/System/src/SystemProcess_Method@Methods.F90 rename src/submodules/System/src/{System_Method@SignalMethods.F90 => SystemSignal_Method@Methods.F90} (75%) delete mode 100644 src/submodules/System/src/System_Method@GetMethods.F90 rename src/submodules/System/src/{System_Method@UtilityMethods.F90 => System_Utility@Methods.F90} (89%) diff --git a/.helix/config.toml b/.helix/config.toml new file mode 100644 index 000000000..a6232d4a2 --- /dev/null +++ b/.helix/config.toml @@ -0,0 +1,2 @@ +[editor] +workspace-lsp-roots = ["CMakeLists.txt", ".git"] diff --git a/src/modules/System/CMakeLists.txt b/src/modules/System/CMakeLists.txt index 61920f420..4b7ddadaf 100644 --- a/src/modules/System/CMakeLists.txt +++ b/src/modules/System/CMakeLists.txt @@ -18,7 +18,16 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/SystemInterface.F90 ${src_path}/System_Method.F90 + PRIVATE + ${src_path}/SystemInterface.F90 + ${src_path}/SystemOptions.F90 + ${src_path}/System_Method.F90 + ${src_path}/SystemSignal_Method.F90 + ${src_path}/SystemFile_Method.F90 + ${src_path}/SystemEnvironment_Method.F90 + ${src_path}/SystemEnquiry_Method.F90 + ${src_path}/SystemProcess_Method.F90 + ${src_path}/System_Utility.F90 ) set(subproject_name "easifemSystem") diff --git a/src/modules/System/src/SystemEnquiry_Method.F90 b/src/modules/System/src/SystemEnquiry_Method.F90 new file mode 100755 index 000000000..19d6523ea --- /dev/null +++ b/src/modules/System/src/SystemEnquiry_Method.F90 @@ -0,0 +1,293 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# System_Method +! +! M_system(3fm) is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. + +MODULE SystemEnquiry_Method +USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR +USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER, C_NULL_CHAR, C_NULL_PTR +USE ISO_C_BINDING, ONLY: C_LONG, C_SHORT, C_FUNPTR + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: System_Access +!! determine filename access or existence +PUBLIC :: System_Isdir +!! determine if filename is a directory +PUBLIC :: System_Islnk +!! determine if filename is a link +PUBLIC :: System_Isreg +!! determine if filename is a regular file +PUBLIC :: System_Isblk +!! determine if filename is a block device +PUBLIC :: System_Ischr +!! determine if filename is a character device +PUBLIC :: System_Isfifo +!! determine if filename is a fifo - named pipe +PUBLIC :: System_Issock +!! determine if filename is a socket + +!---------------------------------------------------------------------------- +! System_Access@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Check accessibility or existence of a pathname +! +!# System_Access +! +! The system_access(3f) function checks pathname existence and access +! permissions. The function checks the pathname for accessibility +! according to the bit pattern contained in amode, using the real user +! ID in place of the effective user ID and the real group ID in place +! of the effective group ID. +! +! The value of amode is either the bitwise-inclusive OR of the access +! permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Access_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Access(pathname, amode) + CHARACTER(len=*), INTENT(IN) :: pathname + !! a character string representing a directory pathname. + !! Trailing spaces are ignored. + INTEGER, INTENT(IN) :: amode + !! bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. + LOGICAL :: System_Access + !! Return value: If not true an error occurred or + !! the requested access is not granted + END FUNCTION System_Access +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Issock@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a socket +! +!# System_Issock +! +! The issock(3f) function checks if path is a path to a socket + +INTERFACE + MODULE FUNCTION System_Issock(pathname) + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a socket pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Issock + !! The system_issock() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Issock +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Isfifo@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: check if argument is a fifo named pipe +! +!# System_Isfifo +! +! Check if argument is a fifo named pipe. + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Isfifo(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + !! a character string representing a fifo - named pipe pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Isfifo + !! The system_isfifo() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Isfifo +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Ischr@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a character device +! +!# System_Ischr +! +! The ischr(3f) function checks if path is a path to a character device. + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Ischr(pathname) + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a character device pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Ischr + !! The system_ischr() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Ischr +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Isreg@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a regular file +! +!# System_Isreg +! +! The isreg(3f) function checks if path is a regular file +! +!## Examples 1 +! +!```fortran +! {{% fortran-code file="examples/System_Isreg_test_1.F90" %}} +!``` +! +!## Examples 2 +! +!```fortran +! {{% fortran-code file="examples/System_Isreg_test_2.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL impure FUNCTION System_Isreg(pathname) + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Isreg + !! The system_isreg() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Isreg +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Islnk@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a link +! +!# System_Islnk +! +! The islnk(3f) function checks if path is a path to a link. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Islink_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Islnk(pathname) + CHARACTER(len=*), INTENT(in) :: pathname + !! a character string representing a link + !! pathname. Trailing spaces are ignored. + LOGICAL :: System_Islnk + !! The system_islnk() function should always be + !! successful and no return value is reserved to + !! indicate an error. + END FUNCTION System_Islnk +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Isblk@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Check if argument is a block device +! +!# System_Isblk +! +! The isblk(3f) function checks if path is a path to a block device. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Isblk_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Isblk(pathname) + CHARACTER(*), INTENT(IN) :: pathname + !! a character string representing a block device pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Isblk + !! The system_isblk() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Isblk +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Isdir@EnquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: checks if argument is a directory of not +! +!# System_Isdir +! +! The system_isdir(3f) function checks if path is a directory. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Isdir_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Isdir(dirname) + CHARACTER(len=*), INTENT(in) :: dirname + !! a character string representing a directory pathname. + !! Trailing spaces are ignored. + LOGICAL :: System_Isdir + !! The system_isdir() function should always be successful and no + !! return value is reserved to indicate an error. + END FUNCTION System_Isdir +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemEnquiry_Method diff --git a/src/modules/System/src/SystemEnvironment_Method.F90 b/src/modules/System/src/SystemEnvironment_Method.F90 new file mode 100755 index 000000000..aadcb97ba --- /dev/null +++ b/src/modules/System/src/SystemEnvironment_Method.F90 @@ -0,0 +1,258 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# System_Method +! +! M_system(3fm) is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. + +MODULE SystemEnvironment_Method +USE ISO_C_BINDING, ONLY: C_LONG +IMPLICIT NONE + +PRIVATE +PUBLIC :: System_Putenv +PUBLIC :: System_Getenv +PUBLIC :: Set_Environment_Variable +PUBLIC :: System_Unsetenv +PUBLIC :: System_Readenv +PUBLIC :: System_Clearenv + +INTEGER(C_LONG), BIND(c, name="longest_env_variable") :: & + LONGEST_ENV_VARIABLE + +!---------------------------------------------------------------------------- +! System_Putenv@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Set environment variable from Fortran +! +!# System_Putenv +! +! The system_putenv() function adds or changes the value +! of environment variables. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Putenv_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Putenv(string, err) + CHARACTER(*), INTENT(IN) :: string + !! string of format "NAME=value". + !! If name does not already exist in the environment, + !! then string is added to the environment. + !! If name does exist, then the value of name in the environment is + !! changed to value. + !! The string passed to putenv(3c) becomes part of the environment, + !! so this routine creates a string each time it is called that + !! increases the amount of + !! memory the program uses. + INTEGER, OPTIONAL, INTENT(OUT) :: err + !! The system_putenv() function returns zero on success, + !! or nonzero if an error occurs. + !! A non-zero error usually indicates sufficient memory + !! does not exist to store the + !! variable. + END SUBROUTINE System_Putenv +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getenv@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: get environment variable +! +!# System_Getenv +! +! The system_getenv() function gets the value of an environment variable. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getenv_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Getenv(name, default) RESULT(VALUE) + CHARACTER(*), INTENT(IN) :: name + !! Return the value of the specified environment variable or + !! blank if the variable is not defined. + CHARACTER(*), INTENT(IN), OPTIONAL :: default + !! If the value returned would be blank this value will be used + !! instead. + CHARACTER(:), ALLOCATABLE :: VALUE + END FUNCTION System_Getenv +END INTERFACE + +!---------------------------------------------------------------------------- +! Set_Environment_Variable@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: call setenv(3c) to set environment variable +! +!# Set_Environment +! +! The set_environment_variable() procedure adds or changes the value of +! environment variables. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/Set_Environment_Variable_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE Set_Environment_Variable(NAME, VALUE, STATUS) + CHARACTER(*), INTENT(IN) :: NAME + !! If name does not already exist in the environment, + !! then string is added to the environment. + !! If name does exist, then the value of name in the environment + !! is changed to value. + CHARACTER(*), INTENT(IN) :: VALUE + !! Value to assign to environment variable NAME + INTEGER, OPTIONAL, INTENT(OUT) :: STATUS + !! returns zero on success, or nonzero if an error occurs. + !! A non-zero error usually indicates sufficient memory does + !! not exist to store the + !! variable. + END SUBROUTINE Set_Environment_Variable +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Clearenv@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Clear environment by calling clearenv(3c) +! +!# System_Clearenv +! +! The System_Clearenv() procedure clears the environment of all name-value +! pairs. Typically used in security-conscious applications or ones where +! configuration control requires ensuring specific variables are set. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Clearenv_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Clearenv(ierr) + INTEGER, INTENT(OUT), OPTIONAL :: ierr + !! returns zero on success, and a nonzero value on failure. Optional. + !! If not present and an error occurs the program stops. + END SUBROUTINE System_Clearenv +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Unsetenv@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: delete an environment variable by calling unsetenv(3c) +! +!# System_Unsetenv +! +! The System_Unsetenv(3f) function deletes the variable name from the +! environment. + +INTERFACE + MODULE SUBROUTINE System_Unsetenv(name, ierr) + CHARACTER(*), INTENT(IN) :: name + !! name of variable to delete. + !! If name does not exist in the environment, then the + !! function succeeds, and the environment is unchanged. + INTEGER, INTENT(OUT), OPTIONAL :: ierr + !! The system_unsetenv(3f) function returns zero on success, + !! or -1 on error. + !! name is NULL, points to a string of length 0, or + !! contains an '=' character. + !! Insufficient memory to add a new variable to the environment. + END SUBROUTINE System_Unsetenv +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Readenv@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: step thru and read environment table +! +! ## System_Readenv +! +! This routine provides a simple interface for reading the environment +! variable table of the current process. +! +! The recommended usage pattern is as follows: +! +! - Call `system_initenv(3f)` to initialize access to the environment +! table. +! +! - Repeatedly call `system_readenv(3f)` to read entries from the +! environment table. +! +! - Reading terminates when a blank line is returned. +! +! ### Notes +! +! - If more than one thread reads the environment simultaneously, the +! results are undefined. +! +! - If the environment is modified while it is being read, the results +! are also undefined. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Readenv_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Readenv() RESULT(string) + CHARACTER(:), ALLOCATABLE :: string + !! the string returned from the environment of the form "NAME=VALUE" + END FUNCTION System_Readenv +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemEnvironment_Method diff --git a/src/modules/System/src/SystemFile_Method.F90 b/src/modules/System/src/SystemFile_Method.F90 new file mode 100755 index 000000000..d160fbf88 --- /dev/null +++ b/src/modules/System/src/SystemFile_Method.F90 @@ -0,0 +1,1079 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# SystemFile_Method +! +! SystemFile_Method is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. + +MODULE SystemFile_Method +USE ISO_C_BINDING, ONLY: C_INT +USE ISO_C_BINDING, ONLY: C_PTR +IMPLICIT NONE + +PRIVATE + +!---------------------------------------------------------------------------- +! System_Utime@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Set file access and modification times +! +!# System_Utime +! +! The system_utime(3f) function sets the access and modification +! times of the file named by the path argument by calling utime(3c). +! +! If times() is not present the access and modification times of +! the file shall be set to the current time. +! +! To use system_utime(3f) the effective user ID of the process must +! match the owner of the file, or the process has to have write +! permission to the file or have appropriate privileges, +! +!## Errors +! +!The underlying utime(3c) function fails if: +! +!### EACCES +! +! Search permission is denied by a component of the path +! prefix; or the times argument is a null pointer and the +! effective user ID of the process does not match the owner +! of the file, the process does not have write permission +! for the file, and the process does not have appropriate +! privileges. +! +!### ELOOP +! +! A loop exists in symbolic links encountered during +! resolution of the path argument. +! +!### ENAMETOOLONG +! +! The length of a component of a pathname is longer than {NAME_MAX}. +! +!### ENOENT +! +! A component of path does not name an existing file or path is an +! empty string. +! +!### ENOTDIR +! +! A component of the path prefix names an existing file +! that is neither a directory nor a symbolic link to a +! directory, or the path argument contains at least one +! non- character and ends with one or more trailing +! characters and the last pathname component +! names an existing file that is neither a directory nor +! a symbolic link to a directory. +! +!### EPERM +! +! The times argument is not a null pointer and the effective +! user ID of the calling process does not match the owner +! of the file and the calling process does not have +! appropriate privileges. +! +!### EROFS +! +! The file system containing the file is read-only. +! +!## Note +! +! The utime() function may fail if: +! +!- ELOOP More than {SYMLOOP_MAX} symbolic links were encountered +!during resolution of the path argument. +! +!- ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, or +! pathname resolution of a symbolic link produced +! an intermediate result with a length that exceeds +! {PATH_MAX}. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Utime_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Utime(pathname, times) + CHARACTER(len=*), INTENT(in) :: pathname + !!name of the file whose access and modification times are to be updated. + INTEGER, INTENT(in), OPTIONAL :: times(2) + !! If present, the values will be interpreted as the access + !! and modification times as Unix Epoch values. That is, + !! they are times measured in seconds since the Unix Epoch. + LOGICAL :: System_Utime + !! Upon successful completion .TRUE. is returned. Otherwise, + !! .FALSE. is returned and errno shall be set to indicate the error, + !! and the file times remain unaffected. + END FUNCTION System_Utime +END INTERFACE + +!---------------------------------------------------------------------------- +! System_RealPath@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Resolve the relative path +! +!# System_Realpath +! +! system_realpath(3f) calls the C routine realpath(3c) to obtain +! the absolute pathname of given path +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Realpath_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Realpath(input) RESULT(string) + CHARACTER(*), INTENT(in) :: input + !! pathname to resolve + CHARACTER(:), ALLOCATABLE :: string + !! The absolute pathname of the given input pathname. + !! The pathname shall contain no components that are dot + !! or dot-dot, or are symbolic links. It is equal to the + !! NULL character if an error occurred. + END FUNCTION System_Realpath +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Chown@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: change file owner and group +! +!# System_Chown +! +! Elemental impure logical function system_chown(path,owner,group) +! +! The chown(3f) function changes owner and group of a file +! +! The path argument points to a pathname naming a file. The +! user ID and group ID of the named file shall be set to the numeric +! values contained in owner and group, respectively. +! +! Only processes with an effective user ID equal to the user ID of +! the file or with appropriate privileges may change the ownership +! of a file. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Chown_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Chown(dirname, owner, group) + CHARACTER(*), INTENT(IN) :: dirname + !! A character string representing a file pathname. + !! Trailing spaces are ignored. + INTEGER, INTENT(IN) :: owner + !! UID of owner that ownership is to be changed to + INTEGER, INTENT(IN) :: group + !! GID of group that ownership is to be changed to + LOGICAL :: System_Chown + !! The system_chown(3f) function should return zero 0 if successful. + !! Otherwise, these functions shall return 1 and set errno to + !! indicate the error. If 1 is returned, no changes are made in + !! the user ID and group ID of the file. + END FUNCTION System_Chown +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Link@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: link one file to another file relative to two directory +! descriptors +! +!# System_Link +! +! The link() function shall create a new link (directory entry) +! for the existing file, path1. +! +! The path1 argument points to a pathname naming an existing +! file. The path2 argument points to a pathname naming the +! new directory entry to be created. The link() function shall +! atomically create a new link for the existing file and the link +! count of the file shall be incremented by one. +! +! If path1 names a directory, link() shall fail unless the process +! has appropriate privileges and the implementation supports using +! link() on directories. +! +! If path1 names a symbolic link, it is implementation-defined +! whether link() follows the symbolic link, or creates a new link +! to the symbolic link itself. +! +! Upon successful completion, link() shall mark for update the +! last file status change timestamp of the file. Also, the last +! data modification and last file status change timestamps of the +! directory that contains the new entry shall be marked for update. +! +! If link() fails, no link shall be created and the link count of +! the file shall remain unchanged. +! +! The implementation may require that the calling process has +! permission to access the existing file. +! +! The linkat() function shall be equivalent to the link() function +! except that symbolic links shall be handled as specified by the +! value of flag (see below) and except in the case where either path1 +! or path2 or both are relative paths. In this case a relative path +! path1 is interpreted relative to the directory associated with +! the file descriptor fd1 instead of the current working directory +! and similarly for path2 and the file descriptor fd2. If the +! file descriptor was opened without O_SEARCH, the function shall +! check whether directory searches are permitted using the current +! permissions of the directory underlying the file descriptor. If +! the file descriptor was opened with O_SEARCH, the function shall +! not perform the check. +! +! Values for flag are constructed by a bitwise-inclusive OR of +! flags from the following list, defined in : +! +! AT_SYMLINK_FOLLOW +! If path1 names a symbolic link, a new link for the target +! of the symbolic link is created. +! +! If linkat() is passed the special value AT_FDCWD in the fd1 or +! fd2 parameter, the current working directory shall be used for the +! respective path argument. If both fd1 and fd2 have value AT_FDCWD, +! the behavior shall be identical to a call to link(), except that +! symbolic links shall be handled as specified by the value of flag. +! +! Some implementations do allow links between file systems. +! +! If path1 refers to a symbolic link, application developers should +! use linkat() with appropriate flags to select whether or not the +! symbolic link should be resolved. +! +! If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and +! the path1 argument names a symbolic link, a new link is created +! for the symbolic link path1 and not its target. + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Link(oldname, newname) RESULT(ierr) + CHARACTER(len=*), INTENT(IN) :: oldname + CHARACTER(len=*), INTENT(IN) :: newname + INTEGER :: ierr + !! Upon successful completion, these functions shall return + !! 0. Otherwise, these functions shall return -1 and set errno to + !! indicate the error. + END FUNCTION System_Link +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Unlink@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: remove a directory entry relative to directory file descriptor +! +!# System_Unlink +! +! The unlink() function shall remove a link to a file. If path names a +! symbolic link, unlink() shall remove the symbolic link named by path +! and shall not affect any file or directory named by the contents of +! the symbolic link. Otherwise, unlink() shall remove the link named by +! the pathname pointed to by path and shall decrement the link count of +! the file referenced by the link. +! +! When the files link count becomes 0 and no process has the file open, +! the space occupied by the file shall be freed and the file shall no +! longer be accessible. If one or more processes have the file open when +! the last link is removed, the link shall be removed before unlink() +! returns, but the removal of the file contents shall be postponed until +! all references to the file are closed. +! +! The path argument shall not name a directory unless the process has +! appropriate privileges and the implementation supports using unlink() +! on directories. +! +! Upon successful completion, unlink() shall mark for update the last +! data modification and last file status change timestamps of the parent +! directory. Also, if the file link count is not 0, the last file status +! change timestamp of the file shall be marked for update. +! +! Values for flag are constructed by a bitwise-inclusive OR of flags from +! the following list, defined in : +! +! AT_REMOVEDIR +! +! Remove the directory entry specified by fd and path as a +! directory, not a normal file. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Unlink_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Unlink(fname) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: fname + INTEGER :: ierr + !! Upon successful completion, these functions shall return 0. Otherwise, + !! these functions shall return -1 and set errno to indicate the error. + !! If -1 is returned, the named file shall not be changed. + END FUNCTION System_Unlink +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Setumask@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Set the file mode creation umask +! +!# System_Setumask +! +! The `system_umask(3f)` function sets the file mode creation mask of +! the calling process to `cmask` and returns the previous value of +! the mask. +! +! Only the file permission bits of `cmask` (see ``) are +! used. The interpretation of any other bits is +! implementation-defined. +! +!### Effect of the file creation mask +! +! The file mode creation mask is applied to the `mode` argument +! supplied to the following functions: +! +! - `open()`, `openat()`, `creat()` +! - `mkdir()`, `mkdirat()`, `mkfifo()`, `mkfifoat()` +! - `mknod()`, `mknodat()` +! - `mq_open()` +! - `sem_open()` +! +!## Semantics +! +! - Bit positions that are set in `cmask` are cleared in the `mode` +! of any subsequently created file or object. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Setumask_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Setumask(Umask_Value) RESULT(Old_Umask) + INTEGER, INTENT(in) :: Umask_Value + INTEGER :: Old_Umask + !! The file permission bits in the value returned by umask() shall be + !! the previous value of the file mode creation mask. The state of any + !! other bits in that value is unspecified, except that a subsequent + !! call to umask() with the returned value as cmask shall leave the + !! state of the mask the same as its state before the first call, + !! including any unspecified use of those bits. + END FUNCTION System_Setumask +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Chdir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: change working directory +! +!# System_Chdir +! +! The `system_chdir(3f)` procedure changes the current working directory +! of the calling process to the directory specified by `path`. +! +! The current working directory is used as the starting point for +! interpreting relative pathnames (those not beginning with `/`). +! +!## Errors +! +! On failure, an error condition is reported as described below. The +! specific error returned may depend on the underlying file system. +! +! The following errors correspond to the C `chdir()` definitions: +! +! - `EACCES` +! Search permission is denied for one of the components of `path`. +! See also `path_resolution(7)`. +! +! - `EFAULT` +! `path` points outside the accessible address space. +! +! - `EIO` +! An I/O error occurred. +! +! - `ELOOP` +! Too many symbolic links were encountered while resolving `path`. +! +! - `ENAMETOOLONG` +! `path` is too long. +! +! - `ENOENT` +! The specified file does not exist. +! +! - `ENOMEM` +! Insufficient kernel memory was available. +! +! - `ENOTDIR` +! A component of `path` is not a directory. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Chdir_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Chdir(path, err) + CHARACTER(len=*), INTENT(IN) :: path + INTEGER, OPTIONAL, INTENT(OUT) :: err + !! On success, zero is returned. On error, -1 is returned, and errno is + !! set appropriately. + END SUBROUTINE System_Chdir +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Remove@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: remove a file +! +!# System_Remove +! +! Fortran supports scratch files via the OPEN(3c) command; but does +! not otherwise allow for removing files. The system_remove(3f) command +! allows for removing files by name that the user has the authority to +! remove by calling the C remove(3c) function. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Remove_test_1.F90" %}} +!``` + +INTERFACE + MODULE ELEMENTAL IMPURE FUNCTION System_Remove(path) RESULT(err) + CHARACTER(*), INTENT(in) :: path + INTEGER(C_INT) :: err + END FUNCTION System_Remove +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Rename@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: rename a system file +! +!# System_Rename +! +! Rename a file by calling rename(3c). It is not recommended that the +! rename occur while either filename is being used on a file currently +! OPEN(3f) by the program. +! Both the old and new names must be on the same device. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Rename_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Rename(input, output) RESULT(ierr) + CHARACTER(*), INTENT(IN) :: input, output + !! system filename of an existing file to rename + !! system filename to be created or overwritten by INPUT file. + !! Must be on the same device as the INPUT file. + INTEGER :: ierr + !! zero (0) if no error occurs. If not zero a call to + !! system_errno(3f) or system_perror(3f) is supported + !! to diagnose error + END FUNCTION System_Rename +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Chmod@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: call chmod to change permission mode of a file +! relative to directory file descriptor +! +!# System_Chmod +! +! The `system_chmod(3f)` function changes the `S_ISUID`, `S_ISGID`, +! `S_ISVTX`, and file permission bits of the file specified by `path` +! to the corresponding bits in the `mode` argument. +! +! The application shall ensure that the effective user ID of the +! calling process matches the owner of the file, or that the process +! has sufficient privileges. +! +! The constants `S_ISUID`, `S_ISGID`, `S_ISVTX`, and the file +! permission bits are defined in ``. +! +!## Privilege and group semantics +! +! - If the calling process lacks appropriate privileges, and +! the group ID of the file does not match the effective group ID +! or any supplementary group ID, then `S_ISGID` is cleared on +! successful return when the file is a regular file. +! +! - Additional implementation-defined restrictions may cause the +! `S_ISUID` and `S_ISGID` bits in `mode` to be ignored. +! +!## Timestamps +! +! - Upon successful completion, `system_chmod()` marks the last +! file status change timestamp of the file for update. +! +!## Flags +! +! Values for `flag` are constructed using a bitwise-inclusive OR of +! the following values defined in ``: +! +! - `AT_SYMLINK_NOFOLLOW` +! If `path` names a symbolic link, the mode of the symbolic link +! itself is changed rather than the target. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Chmod_test_1.F90" %}} +!``` +! +INTERFACE + MODULE FUNCTION System_Chmod(filename, mode) RESULT(ierr) + CHARACTER(*), INTENT(IN) :: filename + INTEGER, VALUE, INTENT(IN) :: mode + INTEGER :: ierr + !! Upon successful completion, system_chmod(3f) returns 0. + !! Otherwise, it returns -1 and sets errno to indicate the error. If + !! -1 is returned, no change to the file mode occurs. + END FUNCTION System_Chmod +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getcwd@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get current working directory +! +!# System_Getcwd +! +! Get current working directory +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getcwd_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Getcwd(output, ierr) + CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output + !! The absolute pathname of the current working directory + !! The pathname shall contain no components that are dot or dot-dot, + !! or are symbolic links. + INTEGER, INTENT(out) :: ierr + !! ierr is not zero if an error occurs. + END SUBROUTINE System_Getcwd +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Rmdir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: remove empty directories +! +!# System_Rmdir +! +! Remove empty directories. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Rmdir_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Rmdir(dirname) RESULT(err) + CHARACTER(*), INTENT(IN) :: dirname + !! The name of a directory to remove if it is empty + INTEGER(C_INT) :: err + !! zero (0) if no error occurred + END FUNCTION System_Rmdir +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Mkfifo@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: make a FIFO special file relative to directory file descriptor +! +!# System_Mkfifo +! +! A regular pipe can only connect two related processes. It is created +! by a process and vanishes when the last process closes it. +! +! A named pipe, also known as a FIFO, can connect two unrelated +! processes and exists independently of the processes using it. +! A FIFO is created using the `mkfifo()` library function. +! +!## Behavior and semantics +! +! - `mkfifo()` creates a new FIFO special file specified by `pathname`. +! - The file permission bits of the new FIFO are initialized from +! `mode`. +! - The permission bits specified in `mode` are modified by the +! process file creation mask. +! - If bits other than file permission bits are set in `mode`, +! the effect is implementation-defined. +! - If `pathname` names a symbolic link, `mkfifo()` fails and sets +! `errno` to `EEXIST`. +! - The FIFO user ID is set to the effective user ID of the process. +! - The FIFO group ID is set either to the group ID of the parent +! directory or to the effective group ID of the process. +! - Implementations shall provide a method to initialize the FIFO +! group ID from the parent directory. +! - Implementations may optionally provide a method to initialize +! the FIFO group ID from the effective group ID of the caller. +! - Upon successful completion, the FIFO last access, modification, +! and status change timestamps are marked for update. +! - The directory containing the new FIFO also has its modification +! and status change timestamps updated. +! +!## Permission modes +! +! Predefined variables are typically used to specify permission modes. +! These variables may be combined using a bytewise OR operation. +! +! Permission bits by category: +! +! - **User** +! - `R_USR` : read +! - `W_USR` : write +! - `X_USR` : execute +! +! - **Group** +! - `R_GRP` : read +! - `W_GRP` : write +! - `X_GRP` : execute +! +! - **Others** +! - `R_OTH` : read +! - `W_OTH` : write +! - `X_OTH` : execute +! +!## Shortcut constants +! +! The following predefined constants represent common combinations: +! +! - `RWX_U` : read, write, execute for user +! - `RWX_G` : read, write, execute for group +! - `RWX_O` : read, write, execute for others +! - `DEFFILEMODE` +! Equivalent to octal `0666` (`rw-rw-rw-`) +! - `ACCESSPERMS` +! Equivalent to octal `0777` (`rwxrwxrwx`) +! +!## Examples +! +! To grant read, write, and execute permissions only to the user: +! +! - `ierr = mkfifo("myfile", IANY([R_USR, W_USR, X_USR]))` +! - `ierr = mkfifo("myfile", RWX_U)` +! +! To grant full permissions to all users (mode `0777`): +! +! - `ierr = mkfifo("myfile", IANY([R_USR, W_USR, X_USR, R_GRP, W_GRP, & +! X_GRP, R_OTH, W_OTH, X_OTH]))` +! - `ierr = mkfifo("myfile", IANY([RWX_U, RWX_G, RWX_O]))` +! - `ierr = mkfifo("myfile", ACCESSPERMS)` +! +!```fortran +! {{% fortran-code file="examples/System_Mkfifo_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Mkfifo(pathname, mode) RESULT(err) + CHARACTER(*), INTENT(IN) :: pathname + INTEGER, INTENT(IN) :: mode + INTEGER :: err + !! Upon successful completion, return 0. + !! Otherwise, return -1 and set errno to indicate the error. + !! If -1 is returned, no FIFO is created. + END FUNCTION System_Mkfifo +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Mkdir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: call mkdir(3c) to create a new directory +! +!# System_Mkdir +! +! Predefined variables are typically used to set permission modes. +! These variables can be combined using a bytewise OR operation to +! create commonly used permission settings. +! +! Permission bits by category: +! +! - **User** +! - `R_USR` : read +! - `W_USR` : write +! - `X_USR` : execute +! +! - **Group** +! - `R_GRP` : read +! - `W_GRP` : write +! - `X_GRP` : execute +! +! - **Others** +! - `R_OTH` : read +! - `W_OTH` : write +! - `X_OTH` : execute +! +! Additional shortcut constants are provided. These are predefined +! bitwise-OR combinations of the permission flags listed above: +! +! - `RWX_U` : read, write, and execute for user +! - `RWX_G` : read, write, and execute for group +! - `RWX_O` : read, write, and execute for others +! - `DEFFILEMODE` +! Equivalent to octal `0666` (`rw-rw-rw-`) +! - `ACCESSPERMS` +! Equivalent to octal `0777` (`rwxrwxrwx`) +! +! To grant only the user read, write, and execute permissions, while +! denying all permissions to group members and others, any of the +! following `mkdir()` calls may be used equivalently: +! +! - `ierr = mkdir("mydir", IANY([R_USR, W_USR, X_USR]))` +! - `ierr = mkdir("mydir", RWX_U)` +! +! To grant full permissions to all users (mode `0777`, `rwxrwxrwx`), +! any of the following calls may be used equivalently: +! +! - `ierr = mkdir("mydir", IANY([R_USR, W_USR, X_USR, R_GRP, W_GRP, X_GRP, & +! R_OTH, W_OTH, X_OTH]))` +! - `ierr = mkdir("mydir", IANY([RWX_U, RWX_G, RWX_O]))` +! - `ierr = mkdir("mydir", ACCESSPERMS)` +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Mkdir_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Mkdir(dirname, mode) RESULT(ierr) + CHARACTER(len=*), INTENT(in) :: dirname + INTEGER, INTENT(in) :: mode + INTEGER :: ierr + END FUNCTION System_Mkdir +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Opendir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: open directory stream by calling opendir +! +!# System_Opendir +! +! The `system_opendir(3f)` procedure opens a directory stream that +! corresponds to the directory specified by the `dirname` argument. +! +! The directory stream is positioned at the first directory entry. +! +!## Return value +! +! - Upon successful completion, a pointer to a C `DIR` type is returned. +! +! - On failure, a null pointer is returned and `IERR` is set to indicate +! the error condition. +! +!## Errors +! +! Errors correspond to the conditions described for `opendir(3c)`, +! including the following: +! +! - `EACCES` +! Search permission is denied for a component of the path prefix of +! `dirname`, or read permission is denied for `dirname`. +! +! - `ELOOP` +! A loop exists in symbolic links encountered during resolution of +! the `dirname` argument. +! +! - `ENAMETOOLONG` +! The length of a pathname component exceeds `{NAME_MAX}`. +! +! - `ENOENT` +! A component of `dirname` does not name an existing directory, or +! `dirname` is an empty string. +! +! - `ENOTDIR` +! A component of `dirname` names an existing file that is neither a +! directory nor a symbolic link to a directory. +! +! - `ELOOP` +! More than `{SYMLOOP_MAX}` symbolic links were encountered during +! resolution of the `dirname` argument. +! +! - `EMFILE` +! All file descriptors available to the process are currently open. +! +! - `ENAMETOOLONG` +! The length of a pathname exceeds `{PATH_MAX}`, or pathname +! resolution of a symbolic link produced an intermediate result whose +! length exceeds `{PATH_MAX}`. +! +! - `ENFILE` +! Too many files are currently open in the system. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Opendir_test_1.F90" %}} +!``` +! +INTERFACE + MODULE SUBROUTINE System_Opendir(dirname, dir, ierr) + CHARACTER(len=*), INTENT(IN) :: dirname + !! name of directory to open a directory stream for + TYPE(C_PTR), INTENT(INOUT) :: dir + !! pointer to directory stream. If an + !! error occurred, it will not be associated. + INTEGER, INTENT(OUT) :: ierr + !! ierr 0 indicates no error occurred + END SUBROUTINE System_Opendir +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Readdir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Read a directory +! +!# System_Readdir +! +! system_readdir(3f) returns the name of the directory entry at the +! current position in the directory stream specified by the argument +! DIR, and positions the directory stream at the next entry. It returns +! a null name upon reaching the end of the directory stream. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Readdir_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Readdir(dir, filename, ierr) + TYPE(C_PTR), VALUE :: dir + !! A pointer to the directory opened by system_opendir(3f). + CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename + !! the name of the directory entry at the current position in + !! the directory stream specified by the argument DIR, and + !! positions the directory stream at the next entry. + !! The readdir() function does not return directory entries + !! containing empty names. If entries for dot or dot-dot exist, + !! one entry is returned for dot and one entry is returned + !! for dot-dot. + !! The entry is marked for update of the last data access + !! timestamp each time it is read. + !! reaching the end of the directory stream, the name is a blank name. + INTEGER, INTENT(out) :: ierr + !! If IERR is set to non-zero on return, an error occurred. + END SUBROUTINE System_Readdir +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Rewinddir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Rewind directory stream +! +!# System_Rewinddir +! +! Return to pointer to the beginning of the list for a currently open +! directory list. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Rewinddir_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Rewinddir(dir) + TYPE(C_PTR), VALUE :: dir + !! A C_Pointer assumed to have been allocated by a + !! call to SYSTEM_OPENDIR(3f). + END SUBROUTINE System_Rewinddir +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Closedir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Close a directory stream by calling closedir +! +!# System_Closedir +! +! The SYSTEM_CLOSEDIR(3f) function closes the directory stream +! referred to by the argument DIR. Upon return, the value of DIR may no +! longer point to an accessible object. +! +! system_closedir(3f) may fail if: +! +!- EBADF: The dirp argument does not refer to an open directory stream. +!- EINTR: The closedir() function was interrupted by a signal. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Closedir_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Closedir(dir, ierr) + TYPE(C_PTR), VALUE :: dir + !! directory stream pointer opened by SYSTEM_OPENDIR(3f). + INTEGER, INTENT(out), OPTIONAL :: ierr + !! Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0; + !! otherwise, an error has occurred. + END SUBROUTINE System_Closedir +END INTERFACE + +!---------------------------------------------------------------------------- +! Fileglob@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Read output of an ls(1) command from Fortran +! +!# Fileglob +! +! Non-portable procedure uses the shell and the ls(1) command +! to expand a filename +! and returns a pointer to a list of expanded filenames. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/Fileglob_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE Fileglob(glob, list) + CHARACTER(*), INTENT(IN) :: glob + !! Pattern for the filenames (like: *.txt) + CHARACTER(*), POINTER, INTENT(INOUT) :: list(:) + !! Allocated list of filenames (returned), the caller must deallocate it. + END SUBROUTINE Fileglob +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Dir@FileMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Return filenames in a directory matching specific wildcard strings +! +!# System_Dir +! +! returns an array of filenames in the specified directory matching +! the wildcard string (which defaults to "*"). +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Dir_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Dir(directory, pattern) + CHARACTER(*), INTENT(IN), OPTIONAL :: directory + !! name of directory to match filenames in. Defaults to ".". + CHARACTER(*), INTENT(IN), OPTIONAL :: pattern + !! wildcard string matching the rules of the matchw(3f) function. + !! Basically "*" matches anything, "?" matches any single character + CHARACTER(:), ALLOCATABLE :: System_Dir(:) + !!System_Dir An array right-padded to the length of the longest + !!filename. Note that this means filenames actually containing + !!trailing spaces in their names may be incorrect. + END FUNCTION System_Dir +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemFile_Method diff --git a/src/modules/System/src/SystemInterface.F90 b/src/modules/System/src/SystemInterface.F90 index fdf1269df..17383e16b 100644 --- a/src/modules/System/src/SystemInterface.F90 +++ b/src/modules/System/src/SystemInterface.F90 @@ -16,8 +16,8 @@ ! along with this program. If not, see MODULE SystemInterface -USE ISO_C_BINDING, ONLY: C_INT, C_SIZE_T, C_INTPTR_T, C_LONG -USE ISO_C_BINDING, ONLY: C_PTR, C_FUNPTR, C_CHAR, C_LONG +USE ISO_C_BINDING, ONLY: C_INT, C_SIZE_T, C_INTPTR_T, C_LONG, C_FLOAT +USE ISO_C_BINDING, ONLY: C_LONG_LONG, C_PTR, C_FUNPTR, C_CHAR, C_LONG IMPLICIT NONE PRIVATE @@ -51,6 +51,32 @@ MODULE SystemInterface PUBLIC :: C_RealPath PUBLIC :: C_Issock PUBLIC :: C_Time +PUBLIC :: C_Chown +PUBLIC :: C_Link +PUBLIC :: C_Unlink +PUBLIC :: C_Chdir +PUBLIC :: C_Remove +PUBLIC :: C_Rename +PUBLIC :: C_Chmod +PUBLIC :: C_Setenv +PUBLIC :: C_Unsetenv +PUBLIC :: C_Readenv +PUBLIC :: C_Putenv +PUBLIC :: C_Isfifo +PUBLIC :: C_Ischr +PUBLIC :: C_Isreg +PUBLIC :: C_Islnk +PUBLIC :: C_Isblk +PUBLIC :: C_Isdir +PUBLIC :: C_CPU_Time +PUBLIC :: C_Perror +PUBLIC :: C_Uname +PUBLIC :: C_Gethostname +PUBLIC :: C_Getlogin +PUBLIC :: C_Perm +PUBLIC :: C_Getgrgid +PUBLIC :: C_Getpwuid +PUBLIC :: C_Stat !---------------------------------------------------------------------------- ! System_Alarm @@ -841,6 +867,334 @@ FUNCTION C_Time(tloc) BIND(c, name='time') END FUNCTION C_Time END INTERFACE +!---------------------------------------------------------------------------- +! C_Chown +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Chown(c_dirname, c_owner, c_group) & + BIND(C, name="my_chown") RESULT(c_ierr) + IMPORT :: C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(IN) :: c_dirname(*) + INTEGER(kind=C_INT), INTENT(IN), VALUE :: c_owner + INTEGER(kind=C_INT), INTENT(IN), VALUE :: c_group + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Chown +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Link +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Link(C_Oldname, C_Newname) & + BIND(C, name="link") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Link +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Unlink +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Unlink(C_Fname) & + BIND(C, name="unlink") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Unlink +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Chdir +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(kind=C_INT) FUNCTION C_Chdir(C_Path) & + BIND(C, name="chdir") + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR) :: c_path(*) + END FUNCTION C_Chdir +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Remove +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Remove(C_Path) BIND(c, name="remove") RESULT(c_err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: C_Path(*) + INTEGER(C_INT) :: c_err + END FUNCTION C_Remove +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Rename +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Rename(C_Input, C_Output) BIND(c, name="rename") RESULT(C_Err) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR), INTENT(in) :: C_Input(*) + CHARACTER(kind=C_CHAR), INTENT(in) :: C_Output(*) + INTEGER(C_INT) :: C_Err + END FUNCTION C_Rename +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Chmod +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Chmod(filename, mode) BIND(c, name="chmod") RESULT(ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR), INTENT(IN) :: filename(*) + INTEGER(C_INT), VALUE, INTENT(IN) :: mode + INTEGER(C_INT) :: ierr + END FUNCTION C_Chmod +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Setenv +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(kind=C_INT) FUNCTION C_Setenv(C_Name, C_VALUE) & + BIND(C, NAME="setenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: C_Name(*) + CHARACTER(kind=C_CHAR) :: C_VALUE(*) + END FUNCTION C_Setenv +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Unsetenv +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(kind=C_INT) FUNCTION C_Unsetenv(C_Name) & + BIND(C, NAME="unsetenv") + IMPORT C_INT, C_CHAR + CHARACTER(len=1, kind=C_CHAR) :: C_Name(*) + END FUNCTION C_Unsetenv +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Readenv +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_Readenv(C_String) & + BIND(C, NAME='my_readenv') + IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T + CHARACTER(kind=C_CHAR), INTENT(OUT) :: c_string(*) + END SUBROUTINE C_Readenv +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Putenv +!---------------------------------------------------------------------------- + +INTERFACE + INTEGER(kind=C_INT) FUNCTION C_Putenv(C_String) & + BIND(C, name="putenv") + IMPORT C_INT, C_CHAR + CHARACTER(kind=C_CHAR) :: C_String(*) + END FUNCTION C_Putenv +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Isfifo +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Isfifo(pathname) & + BIND(C, name="my_isfifo") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Isfifo +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Ischr +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Ischr(pathname) & + BIND(C, name="my_ischr") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Ischr +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Isreg +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Isreg(pathname) & + BIND(C, name="my_isreg") RESULT(c_ierr) + IMPORT :: C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Isreg +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Islnk +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Islnk(pathname) & + BIND(C, name="my_islnk") RESULT(c_ierr) + IMPORT C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(IN) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Islnk +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Isblk +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Isblk(pathname) & + BIND(C, name="my_isblk") RESULT(c_ierr) + IMPORT :: C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(IN) :: pathname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Isblk +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Isdir +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Isdir(dirname) & + BIND(C, name="my_isdir") RESULT(c_ierr) + IMPORT :: C_CHAR, C_INT + CHARACTER(kind=C_CHAR, len=1), INTENT(IN) :: dirname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Isdir +END INTERFACE + +!---------------------------------------------------------------------------- +! C_CPU_Time +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_CPU_Time(total, user, system) & + BIND(C, NAME='my_cpu_time') + IMPORT :: C_FLOAT + REAL(C_FLOAT) :: total, user, system + END SUBROUTINE C_CPU_Time +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Perror +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_Perror(prefix) BIND(C, name="perror") + IMPORT C_CHAR + CHARACTER(kind=C_CHAR) :: prefix(*) + END SUBROUTINE C_Perror +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Uname +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_Uname(WHICH, BUF, BUFLEN) BIND(C, NAME='my_uname') + IMPORT :: C_CHAR, C_INT + IMPLICIT NONE + CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH + CHARACTER(KIND=C_CHAR), INTENT(out) :: BUF(*) + INTEGER(C_INT), INTENT(in) :: BUFLEN + END SUBROUTINE C_Uname +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Gethostname +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Gethostname(c_buf, c_buflen) BIND(C, NAME='gethostname') + IMPORT :: C_CHAR, C_INT + INTEGER(kind=C_INT) :: C_Gethostname + CHARACTER(KIND=C_CHAR), INTENT(out) :: c_buf(*) + INTEGER(C_INT), INTENT(in), VALUE :: c_buflen + END FUNCTION C_Gethostname +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Getlogin +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Getlogin() & + BIND(c, name="getlogin") RESULT(c_username) + IMPORT C_INT, C_PTR + TYPE(C_PTR) :: c_username + END FUNCTION C_Getlogin +END INTERFACE + +INTERFACE + FUNCTION C_Perm(c_mode) & + BIND(c, name="my_get_perm") RESULT(c_permissions) + IMPORT C_INT, C_PTR, C_LONG + INTEGER(kind=C_LONG), VALUE :: c_mode + TYPE(C_PTR) :: c_permissions + END FUNCTION C_Perm +END INTERFACE + +INTERFACE + FUNCTION C_Getgrgid(C_Gid, C_Groupname) & + BIND(c, name="my_getgrgid") RESULT(c_ierr) + IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG + INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_gid + CHARACTER(kind=C_CHAR), INTENT(out) :: c_groupname(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Getgrgid +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + FUNCTION C_Getpwuid(C_Uid, C_Username) & + BIND(c, name="my_getpwuid") RESULT(c_ierr) + IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG + INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_uid + CHARACTER(kind=C_CHAR), INTENT(out) :: c_username(*) + INTEGER(kind=C_INT) :: c_ierr + END FUNCTION C_Getpwuid +END INTERFACE + +!---------------------------------------------------------------------------- +! C_Stat +!---------------------------------------------------------------------------- + +INTERFACE + SUBROUTINE C_Stat(buffer, cvalues, cierr, cdebug) & + BIND(c, name="my_stat") + IMPORT :: C_CHAR, C_SIZE_T, C_PTR, C_INT, C_LONG + CHARACTER(kind=C_CHAR), INTENT(IN) :: buffer(*) + INTEGER(C_LONG), INTENT(OUT) :: cvalues(*) + INTEGER(C_INT) :: cierr + INTEGER(C_INT), INTENT(in) :: cdebug + END SUBROUTINE C_Stat +END INTERFACE !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/System/src/SystemOptions.F90 b/src/modules/System/src/SystemOptions.F90 new file mode 100755 index 000000000..13bc1c67e --- /dev/null +++ b/src/modules/System/src/SystemOptions.F90 @@ -0,0 +1,105 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# SystemOptions +! +! System_Method is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. + +MODULE SystemOptions +USE ISO_C_BINDING, ONLY: C_INT +USE ISO_C_BINDING, ONLY: C_CHAR +USE ISO_C_BINDING, ONLY: C_LONG +USE ISO_C_BINDING, ONLY: C_SHORT +USE GlobalData, ONLY: I4B +USE GlobalData, ONLY: INT32 +IMPLICIT NONE + +PRIVATE + +INTEGER(I4B), PARAMETER, PUBLIC :: System_mode_t = INT32 +!! mode_t: This is a specific data type (usually an unsigned integer) used in +!! POSIX systems to store file mode information, such as permissions. + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IRGRP") :: R_GRP +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IROTH") :: R_OTH +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IRUSR") :: R_USR +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IRWXG") :: RWX_G +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IRWXO") :: RWX_O +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IRWXU") :: RWX_U +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IWGRP") :: W_GRP +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IWOTH") :: W_OTH +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IWUSR") :: W_USR +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IXGRP") :: X_GRP +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IXOTH") :: X_OTH +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FS_IXUSR") :: X_USR +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FDEFFILEMODE") :: DEFFILEMODE +INTEGER(System_mode_t), PUBLIC, BIND(c, name="FACCESSPERMS") :: ACCESSPERMS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER(C_INT), PUBLIC, PARAMETER :: F_OK = 0 +INTEGER(C_INT), PUBLIC, PARAMETER :: R_OK = 4 +INTEGER(C_INT), PUBLIC, PARAMETER :: W_OK = 2 +INTEGER(C_INT), PUBLIC, PARAMETER :: X_OK = 1 + +INTEGER(I4B), PARAMETER :: MAX_STR_LEN = 256 + +!---------------------------------------------------------------------------- +! dirent_SYSTEMA +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: dirent_SYSTEMA + INTEGER(C_LONG) :: d_ino + INTEGER(C_LONG) :: d_off + INTEGER(C_SHORT) :: d_reclen + CHARACTER(len=1, kind=C_CHAR) :: d_name(MAX_STR_LEN) +END TYPE dirent_SYSTEMA + +!---------------------------------------------------------------------------- +! dirent_CYGWIN +!---------------------------------------------------------------------------- + +TYPE, BIND(C) :: dirent_CYGWIN + INTEGER(C_INT) :: d_version + INTEGER(C_LONG) :: d_ino + CHARACTER(kind=C_CHAR) :: d_type + CHARACTER(kind=C_CHAR) :: d_unused1(3) + INTEGER(C_INT) :: d_internal1 + CHARACTER(len=1, kind=C_CHAR) :: d_name(MAX_STR_LEN) +END TYPE dirent_CYGWIN + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemOptions diff --git a/src/modules/System/src/SystemProcess_Method.F90 b/src/modules/System/src/SystemProcess_Method.F90 new file mode 100755 index 000000000..936b435f6 --- /dev/null +++ b/src/modules/System/src/SystemProcess_Method.F90 @@ -0,0 +1,399 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# SystemProcess_Method +! +! M_system(3fm) is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. + +MODULE SystemProcess_Method +USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR +USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER, C_NULL_CHAR, C_NULL_PTR +USE ISO_C_BINDING, ONLY: C_LONG, C_SHORT, C_FUNPTR +USE GlobalData, ONLY: INT32, INT64 +IMPLICIT NONE + +PRIVATE + +PUBLIC :: System_Perror +PUBLIC :: System_Stat +!! call stat(3c) to determine system information of file by name +PUBLIC :: System_Perm +!! create string representing file permission and type +PUBLIC :: System_Getumask +PUBLIC :: System_cpu_Time +PUBLIC :: System_Uname +PUBLIC :: System_Gethostname +PUBLIC :: System_Getlogin +PUBLIC :: System_Getpwuid +PUBLIC :: System_Getgrgid + +! C types. Might be platform dependent +INTEGER, PARAMETER, PUBLIC :: mode_t = INT32 +! Host names are limited to {HOST_NAME_MAX} bytes. +INTEGER(kind=mode_t), BIND(c, name="FHOST_NAME_MAX") :: HOST_NAME_MAX + +!---------------------------------------------------------------------------- +! System_Cpu_Time@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get processor time by calling times +! +!# System_Cpu_Time +! +! Get processor time by calling times +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Cpu_Time" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Cpu_Time(total, user, system) + REAL, INTENT(OUT) :: user, system, total + !! C_Total total processor time ( C_User + C_System ) + !! C_User processor user time + !! C_System processor system time + END SUBROUTINE System_Cpu_Time +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getumask@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get current umask +! +!# System_Getumask +! +! The return value from getumask(3f) is the value of the file +! creation mask, obtained by using umask(3c). +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getumask_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Getumask() RESULT(Umask_Value) + INTEGER :: Umask_Value + !! The return value from umask() is just the previous value of the file + !! creation mask, so that this system call can be used both to get and + !! set the required values. Sadly, however, + !! there is no way to get the old + !! umask value without setting a new value at the same time. + !! This means that in order just to see the current value, + !! it is necessary + !! to execute a piece of code like the following function: + END FUNCTION System_Getumask +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Perror@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: print error message for last C error on stderr +! +!# System_Perror +! +! Use system_perror(3f) to print an error message on stderr +! corresponding to the current value of the C global variable errno. +! Unless you use NULL as the argument prefix, the error message will +! begin with the prefix string, followed by a colon and a space +! (:). The remainder of the error message produced is one of the +! strings described for strerror(3c). +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Perror_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Perror(prefix) + CHARACTER(len=*), INTENT(IN) :: prefix + END SUBROUTINE System_Perror +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getuname@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get current system information +! +! ## System_Getuname +! +! Given a single-character selector, this routine returns the corresponding +! description of the current operating system. +! +! The `NAMEOUT` variable is assumed to be sufficiently large to hold the +! returned value. +! +! The following selector values are supported: +! +! - `s` Returns the kernel name. +! - `r` Returns the kernel release. +! - `v` Returns the kernel version. +! - `n` Returns the network node hostname. +! - `m` Returns the machine hardware name. +! - `T` Test mode: prints all information in the following order: +! `s r v n m`. + +INTERFACE + MODULE SUBROUTINE System_Uname(WHICH, NAMEOUT) + CHARACTER(KIND=C_CHAR), INTENT(IN) :: WHICH + CHARACTER(*), INTENT(OUT) :: NAMEOUT + END SUBROUTINE System_Uname +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Gethostname@Getmethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get name of current host +! +!# System_Gethostname +! +! The system_gethostname(3f) procedure returns the standard host +! name for the current machine. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Gethostname_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Gethostname(NAME, IERR) + CHARACTER(:), ALLOCATABLE, INTENT(OUT) :: NAME + !! string returns the hostname. + INTEGER, INTENT(OUT) :: IERR + !! Upon successful completion, 0 shall be returned; otherwise, -1 + !! shall be returned. + END SUBROUTINE System_Gethostname +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getlogin@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get login name +! +!## System_Getlogin +! +! The `system_getlogin(3f)` function returns a string containing the user +! name associated with the login activity of the controlling terminal of the +! current process. +! +! If the user name cannot be determined, the function returns a null string +! and sets `errno` to indicate the error. +! +! The following three user names associated with the current process can be +! determined: +! +! - `system_getpwuid(system_getuid())` +! Returns the name associated with the real user ID of the process. +! +! - `system_getpwuid(system_geteuid())` +! Returns the name associated with the effective user ID of the process. +! +! - `system_getlogin()` +! Returns the name associated with the current login activity.!! +!! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getlogin_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Getlogin() RESULT(fname) + CHARACTER(:), ALLOCATABLE :: fname + END FUNCTION System_Getlogin +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Perm@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get file type and permission as a string +! +!# System_Perm +! +! The system_perm(3f) function returns a string containing the type +! and permission of a file implied by the value of the mode value. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Perm_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Perm(mode) RESULT(perms) + CLASS(*), INTENT(IN) :: mode + CHARACTER(len=:), ALLOCATABLE :: perms + !! returns the permission string in a format similar to that + !! used by Unix commands such as ls(1). + END FUNCTION System_Perm +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getgrgid@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-06 +! summary: Get groupd name associated with a GID +! +!# System_Getgrgid +! +! The System_Getgrgid() function returns a string containing the group +! name associated with the given GID. If no match is found +! it returns a null string and sets errno to indicate the error. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getgrgid_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Getgrgid(gid) RESULT(gname) + CLASS(*), INTENT(IN) :: gid + !! GID to try to look up associated group for. Can be of any + !! INTEGER type. + CHARACTER(len=:), ALLOCATABLE :: gname + !! returns the group name. Blank if an error occurs + END FUNCTION System_Getgrgid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Getpwuid@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get login name associated with a UID +! +!# System_Getpwuid +! +! The system_getpwuid() function returns a string containing the user +! name associated with the given UID. If no match is found it returns +! a null string and sets errno to indicate the error. +! +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Getpwuid_test_1.F90" %}} +!``` + +INTERFACE + MODULE FUNCTION System_Getpwuid(uid) RESULT(uname) + CLASS(*), INTENT(IN) :: uid + !! UID to try to look up associated username for. Can be of any + !! INTEGER type. + CHARACTER(:), ALLOCATABLE :: uname + !! returns the login name. + END FUNCTION System_Getpwuid +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Stat@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Get file status information +! +!# System_Stat +! +! This function returns information about a file. No permissions are +! required on the file itself, but execute (search) permission is required +! on all of the directories in path that lead to the file. The elements +! that are obtained and stored in the array VALUES: +! +! | Index | VALUES(n) | Description | +! |-------|-----------|-------------| +! | 1 | VALUES(1) | Device ID | +! | 2 | VALUES(2) | Inode number | +! | 3 | VALUES(3) | File mode | +! | 4 | VALUES(4) | Number of links | +! | 5 | VALUES(5) | Owner UID | +! | 6 | VALUES(6) | Owner GID | +! | 7 | VALUES(7) | ID of device containing dir entry for file | +! | 8 | VALUES(8) | File size (bytes) | +! | 9 | VALUES(9) | Last access time as a Unix Epoch time (seconds) | +! | 10 | VALUES(10) | Last modification time as a Unix Epoch time (seconds) | +! | 11 | VALUES(11) | Last file status change time as a Unix Epoch time | +! | 12 | VALUES(12) | Preferred I/O block size (-1 if not available) | +! | 13 | VALUES(13) | Number of blocks allocated (-1 if not available) | +! +! > [!NOTE] +! > Not all these elements are relevant on all systems. +! > If an element is not relevant, it is returned as `0`.!! +! +! +!## Examples +! +! ```fortran +! {{% fortran-code file="examples/System_Stat_test_1.F90" %}} +! ``` + +INTERFACE + MODULE SUBROUTINE System_Stat(pathname, values, ierr) + CHARACTER(*), INTENT(IN) :: pathname + !! The type shall be CHARACTER, of the default kind and a valid + !! path within the file system. + INTEGER(INT64), INTENT(OUT) :: values(13) + !! VALUES The type shall be INTEGER(8), DIMENSION(13). + INTEGER, OPTIONAL, INTENT(OUT) :: ierr + END SUBROUTINE System_Stat +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemProcess_Method diff --git a/src/modules/System/src/SystemSignal_Method.F90 b/src/modules/System/src/SystemSignal_Method.F90 new file mode 100755 index 000000000..013533c39 --- /dev/null +++ b/src/modules/System/src/SystemSignal_Method.F90 @@ -0,0 +1,127 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# System_Signal +! +! M_system(3fm) is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. +! +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. +! +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. + +MODULE SystemSignal_Method +USE ISO_C_BINDING, ONLY: C_FUNPTR +USE ISO_C_BINDING, ONLY: C_INT +IMPLICIT NONE + +PRIVATE +PUBLIC :: System_Signal +PUBLIC :: handler +PUBLIC :: handler_ptr_array +PUBLIC :: f_handler + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +ABSTRACT INTERFACE + ! mold for signal handler to be installed by system_signal + SUBROUTINE handler(signum) + IMPORT :: C_INT + INTEGER(C_INT), INTENT(IN) :: signum + END SUBROUTINE handler +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +TYPE handler_pointer + PROCEDURE(handler), POINTER, NOPASS :: sub +END TYPE handler_pointer + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTEGER, PARAMETER :: NO_OF_SIGNALS = 64 +!! obtained with command: kill -l +TYPE(handler_pointer) :: handler_ptr_array(NO_OF_SIGNALS) + +!---------------------------------------------------------------------------- +! f_handler@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: handler + +INTERFACE + MODULE SUBROUTINE f_handler(signum) BIND(c) + INTEGER(C_INT), INTENT(IN), VALUE :: signum + END SUBROUTINE f_handler +END INTERFACE + +!---------------------------------------------------------------------------- +! System_Signal@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Install a signal handler +! +!# System_Signal +! +! Calling system_signal(NUMBER, HANDLER) causes user-defined +! subroutine HANDLER to be executed when the signal NUMBER is +! caught. The same subroutine HANDLER maybe installed to handle +! different signals. HANDLER takes only one integer argument which +! is assigned the signal number that is caught. See sample program +! below for illustration. +! +! Calling system_signal(NUMBER) installs a do-nothing handler. This +! is not equivalent to ignoring the signal NUMBER though, because +! the signal can still interrupt any sleep or idle-wait. +! +! Note that the signals SIGKILL and SIGSTOP cannot be handled +! this way. +! +!## Examples +! +!```fortran +! {{% fortran-code file="examples/System_Signal_test_1.F90" %}} +!``` + +INTERFACE + MODULE SUBROUTINE System_Signal(signum, handler_routine) + INTEGER, INTENT(IN) :: signum + PROCEDURE(handler), OPTIONAL :: handler_routine + TYPE(C_FUNPTR) :: ret, c_handler + END SUBROUTINE System_Signal +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE SystemSignal_Method diff --git a/src/modules/System/src/System_Method.F90 b/src/modules/System/src/System_Method.F90 index 77c763827..7b7d7ab43 100755 --- a/src/modules/System/src/System_Method.F90 +++ b/src/modules/System/src/System_Method.F90 @@ -1,7 +1,12 @@ ! This module is mainly taken from the source: ! https://github.com/urbanjost/M_system. +! The Author's name is John S. Urban +! ! The original name of the program has been changed ! from M_SYSTEM to System_Method. +! +! The routine is divided into Modules and Submodules. +! ! This is to confirm to the coding sytles of easifem. ! Original program has been re-organized into module and submodule. ! If you are using easifem for getting methods defined in this @@ -9,2348 +14,32 @@ ! We would like to thank the original author Urban Jost for creating ! This useful module. -!> author: John S. Urban -! date: 2026-02-04 +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-07 ! summary: Fortran interface to C system interface ! !# System_Method ! -! Fortran interface to C system interface. -! -!## Public objects -! -! Public objects: -! -! ! ENVIRONMENT -! use M_system, only : set_environment_variable, system_unsetenv, & -! system_putenv, system_getenv -! -! use M_system, only : system_intenv, system_readenv, system_clearenv -! ! FILE SYSTEM -! use M_system, only : system_getcwd, system_link, & -! system_mkfifo, system_remove, system_rename, & -! system_umask, system_unlink, fileglob, & -! system_rmdir, system_chdir, system_mkdir, & -! system_stat, system_isdir, system_islnk, system_isreg, & -! system_isblk, system_ischr, system_isfifo, & -! system_realpath, & -! system_access, & -! system_utime, & -! system_issock, system_perm, & -! system_dir, & -! system_memcpy -! -! !!use M_system, only : system_getc, system_putc -! ! ERROR PROCESSING -! use M_system, only : system_errno, system_perror -! ! INFO -! use M_system, only : system_getegid, system_geteuid, system_getgid, & -! system_gethostname, system_getpid, system_getppid, system_setsid, & -! system_getsid, system_getuid, system_uname -! ! SIGNALS -! use M_system, only : system_kill,system_signal -! ! RANDOM NUMBERS -! use M_system, only : system_rand, system_srand -! ! PROCESS INFORMATION -! use M_system, only : system_cpu_time -! -!##DESCRIPTION -! -! M_system(3fm) is a collection of Fortran procedures that call C -! or a C wrapper using the ISO_C_BINDING interface to access system calls. -! System calls are a special set of functions used by programs to communicate -! directly with an operating system. -! -! Generally, system calls are slower than normal function calls because -! when you make a call control is relinquished to the operating system -! to perform the system call. In addition, depending on the nature of the -! system call, your program may be blocked by the OS until the system call -! has finished, thus making the execution time of your program even longer. -! -! One rule-of-thumb that should always be followed when calling a system -! call -- Always check the return value. -! -!## ENVIRONMENT ACCESS -! -! o system_putenv(3f): call putenv(3c) -! o system_getenv(3f): function call to get_environment_variable(3f) -! o system_unsetenv(3f): call unsetenv(3c) to remove variable from environment -! o set_environment_variable(3f): set environment variable by calling setenv(3c) -! -! o system_initenv(3f): initialize environment table for reading -! o system_readenv(3f): read next entry from environment table -! o system_clearenv(3f): emulate clearenv(3c) to clear environment -! -!## FILE SYSTEM -! -! o system_chdir(3f): call chdir(3c) to change current directory of a process -! o system_getcwd(3f): call getcwd(3c) to get pathname of current working directory -! -! o system_stat(3f): determine system information of file by name -! o system_perm(3f): create string representing file permission and type -! o system_access(3f): determine filename access or existence -! o system_isdir(3f): determine if filename is a directory -! o system_islnk(3f): determine if filename is a link -! o system_isreg(3f): determine if filename is a regular file -! o system_isblk(3f): determine if filename is a block device -! o system_ischr(3f): determine if filename is a character device -! o system_isfifo(3f): determine if filename is a fifo - named pipe -! o system_issock(3f): determine if filename is a socket -! o system_realpath(3f): resolve a pathname -! -! o system_chmod(3f): call chmod(3c) to set file permission mode -! o system_chown(3f): call chown(3c) to set file owner -! o system_getumask(3f): call umask(3c) to get process permission mask -! o system_setumask(3f): call umask(3c) to set process permission mask -! -! o system_mkdir(3f): call mkdir(3c) to create empty directory -! o system_mkfifo(3f): call mkfifo(3c) to create a special FIFO file -! o system_link(3f): call link(3c) to create a filename link -! -! o system_rename(3f): call rename(3c) to change filename -! -! o system_remove(3f): call remove(3c) to remove file -! o system_rmdir(3f): call rmdir(3c) to remove empty directory -! o system_unlink(3f): call unlink(3c) to remove a link to a file -! o system_utime(3f): call utime(3c) to set file access and modification times -! o system_dir(3f): read name of files in specified directory matching a wildcard string -! -! o fileglob(3f): Returns list of files using a file globbing pattern -! -!## STREAM IO -! -! o system_getc(3f): get a character from stdin -! o system_putc(3f): put a character on stdout -! -!## RANDOM NUMBERS -! -! o system_srand(3f): call srand(3c) -! o system_rand(3f): call rand(3c) -! -!## C ERROR INFORMATION -! -! o system_errno(3f): return errno(3c) -! o system_perror(3f): call perror(3c) to display last C error message -! -!## QUERIES +! M_system(3fm) is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs to communicate +! directly with an operating system. ! -! o system_geteuid(3f): call geteuid(3c) -! o system_getuid(3f): call getuid(3c) -! o system_getegid(3f): call getegid(3c) -! o system_getgid(3f): call getgid(3c) -! o system_getpid(3f): call getpid(3c) -! o system_getppid(3f): call getppid(3c) -! o system_gethostname(3f): get name of current host -! o system_uname(3f): call my_uname(3c) which calls uname(3c) -! o system_getlogin(3f): get login name -! o system_getpwuid(3f): get login name associated with given UID -! o system_getgrgid(3f): get group name associated with given GID -! o system_cpu_time(3f) : get processor time in seconds using times(3c) +! Generally, system calls are slower than normal function calls because +! when you make a call control is relinquished to the operating system +! to perform the system call. In addition, depending on the nature of the +! system call, your program may be blocked by the OS until the system call +! has finished, thus making the execution time of your program even longer. ! -!## FUTURE DIRECTIONS -! -! A good idea of what system routines are commonly required is to refer -! to the POSIX binding standards. (Note: IEEE 1003.9-1992 was withdrawn 6 -! February 2003.) The IEEE standard covering Fortran 77 POSIX bindings -! is available online, though currently (unfortunately) only from -! locations with appropriate subscriptions to the IEEE server (e.g., -! many university networks). For those who do have such access, the link -! is: POSIX Fortran 77 Language Interfaces (IEEE Std 1003.9-1992) (pdf) -! -!## SEE ALSO -! -! Some vendors provide their own way to access POSIX functions and make -! those available as modules; for instance ... -! -! o the IFPORT module of Intel -! o or the f90_* modules of NAG. -! o There are also other compiler-independent efforts to make the -! POSIX procedures accessible from Fortran... -! -! o Posix90 (doc), -! o flib.a platform/files and directories, -! o fortranposix. +! One rule-of-thumb that should always be followed when calling a system +! call -- Always check the return value. MODULE System_Method -USE ISO_C_BINDING, ONLY: C_FLOAT, C_INT, C_CHAR -USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER, C_NULL_CHAR, C_NULL_PTR -USE ISO_C_BINDING, ONLY: C_LONG, C_SHORT, C_FUNPTR - -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT8, INT16, INT32, INT64 -!!, real32, real64, real128, dp=>real128 +USE SystemOptions USE SystemInterface -IMPLICIT NONE - -PRIVATE - -! C types. Might be platform dependent -INTEGER, PARAMETER, PUBLIC :: mode_t = INT32 - -PUBLIC :: system_rand -PUBLIC :: system_srand - -!-!public :: system_getc -!-!public :: system_putc - -PUBLIC :: system_getpid -!! return process ID -PUBLIC :: system_getppid -!! return parent process ID -PUBLIC :: system_getuid, system_geteuid -!! return user ID -PUBLIC :: system_getgid, system_getegid -!! return group ID -PUBLIC :: system_setsid -PUBLIC :: system_getsid -PUBLIC :: system_kill -!! (pid, signal) kill process (defaults: pid=0, signal=SIGTERM) -PUBLIC :: system_signal -!! (signal,[handler]) install signal handler subroutine - -PUBLIC :: system_errno -PUBLIC :: system_perror - -PUBLIC :: system_putenv -PUBLIC :: system_getenv -PUBLIC :: set_environment_variable -PUBLIC :: system_unsetenv - -PUBLIC :: system_initenv -PUBLIC :: system_readenv -PUBLIC :: system_clearenv - -PUBLIC :: system_stat -!! call stat(3c) to determine system information of file by name -PUBLIC :: system_perm -!! create string representing file permission and type -PUBLIC :: system_access -!! determine filename access or existence -PUBLIC :: system_isdir -!! determine if filename is a directory -PUBLIC :: system_islnk -!! determine if filename is a link -PUBLIC :: system_isreg -!! determine if filename is a regular file -PUBLIC :: system_isblk -!! determine if filename is a block device -PUBLIC :: system_ischr -!! determine if filename is a character device -PUBLIC :: system_isfifo -!! determine if filename is a fifo - named pipe -PUBLIC :: system_issock -!! determine if filename is a socket -PUBLIC :: system_realpath -!! resolve pathname - -PUBLIC :: system_chdir -PUBLIC :: system_rmdir -PUBLIC :: system_remove -PUBLIC :: system_rename - -PUBLIC :: system_mkdir -PUBLIC :: system_mkfifo -PUBLIC :: system_chmod -PUBLIC :: system_chown -PUBLIC :: system_link -PUBLIC :: system_unlink -PUBLIC :: system_utime - -PUBLIC :: system_setumask -PUBLIC :: system_getumask -PUBLIC :: system_umask - -PUBLIC :: system_getcwd - -PUBLIC :: system_opendir -PUBLIC :: system_readdir -PUBLIC :: system_rewinddir -PUBLIC :: system_closedir - -PUBLIC :: system_cpu_time - -PUBLIC :: system_uname -PUBLIC :: system_gethostname -PUBLIC :: system_getlogin -PUBLIC :: system_getpwuid -PUBLIC :: system_getgrgid -PUBLIC :: fileglob - -PUBLIC :: system_alarm -PUBLIC :: system_calloc -PUBLIC :: system_clock -PUBLIC :: system_time -!public :: system_time -!public :: system_qsort - -PUBLIC :: system_realloc -PUBLIC :: system_malloc -PUBLIC :: system_free -PUBLIC :: system_memcpy - -PUBLIC :: system_dir - -PUBLIC :: R_GRP, R_OTH, R_USR, RWX_G, RWX_O, RWX_U, W_GRP, W_OTH, W_USR, X_GRP -PUBLIC :: X_OTH, X_USR, DEFFILEMODE, ACCESSPERMS -PUBLIC :: R_OK, W_OK, X_OK, F_OK -!! for system_access - -!---------------------------------------------------------------------------- -! dirent_SYSTEMA -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: dirent_SYSTEMA - INTEGER(C_LONG) :: d_ino - INTEGER(C_LONG) :: d_off - INTEGER(C_SHORT) :: d_reclen - CHARACTER(len=1, kind=C_CHAR) :: d_name(256) -END TYPE dirent_SYSTEMA - -!---------------------------------------------------------------------------- -! dirent_CYGWIN -!---------------------------------------------------------------------------- - -TYPE, BIND(C) :: dirent_CYGWIN - INTEGER(C_INT) :: d_version - INTEGER(C_LONG) :: d_ino - CHARACTER(kind=C_CHAR) :: d_type - CHARACTER(kind=C_CHAR) :: d_unused1(3) - INTEGER(C_INT) :: d_internal1 - CHARACTER(len=1, kind=C_CHAR) :: d_name(256) -END TYPE dirent_CYGWIN - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -integer(kind=c_long),bind(c,name="longest_env_variable") :: longest_env_variable - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER(kind=mode_t), BIND(c, name="FS_IRGRP") :: R_GRP -INTEGER(kind=mode_t), BIND(c, name="FS_IROTH") :: R_OTH -INTEGER(kind=mode_t), BIND(c, name="FS_IRUSR") :: R_USR -INTEGER(kind=mode_t), BIND(c, name="FS_IRWXG") :: RWX_G -INTEGER(kind=mode_t), BIND(c, name="FS_IRWXO") :: RWX_O -INTEGER(kind=mode_t), BIND(c, name="FS_IRWXU") :: RWX_U -INTEGER(kind=mode_t), BIND(c, name="FS_IWGRP") :: W_GRP -INTEGER(kind=mode_t), BIND(c, name="FS_IWOTH") :: W_OTH -INTEGER(kind=mode_t), BIND(c, name="FS_IWUSR") :: W_USR -INTEGER(kind=mode_t), BIND(c, name="FS_IXGRP") :: X_GRP -INTEGER(kind=mode_t), BIND(c, name="FS_IXOTH") :: X_OTH -INTEGER(kind=mode_t), BIND(c, name="FS_IXUSR") :: X_USR -INTEGER(kind=mode_t), BIND(c, name="FDEFFILEMODE") :: DEFFILEMODE -INTEGER(kind=mode_t), BIND(c, name="FACCESSPERMS") :: ACCESSPERMS - -! Host names are limited to {HOST_NAME_MAX} bytes. -INTEGER(kind=mode_t), BIND(c, name="FHOST_NAME_MAX") :: HOST_NAME_MAX - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -! for system_access(3f) -!integer(kind=c_int),bind(c,name="F_OK") :: F_OK -!integer(kind=c_int),bind(c,name="R_OK") :: R_OK -!integer(kind=c_int),bind(c,name="W_OK") :: W_OK -!integer(kind=c_int),bind(c,name="X_OK") :: X_OK -! not sure these will be the same on all systems, but above did not work -INTEGER(kind=C_INT), PARAMETER :: F_OK = 0 -INTEGER(kind=C_INT), PARAMETER :: R_OK = 4 -INTEGER(kind=C_INT), PARAMETER :: W_OK = 2 -INTEGER(kind=C_INT), PARAMETER :: X_OK = 1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -ABSTRACT INTERFACE ! mold for signal handler to be installed by system_signal - SUBROUTINE handler(signum) - INTEGER :: signum - END SUBROUTINE handler -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -TYPE handler_pointer - PROCEDURE(handler), POINTER, NOPASS :: sub -END TYPE handler_pointer - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTEGER, PARAMETER :: no_of_signals = 64 -!! obtained with command: kill -l - -TYPE(handler_pointer), DIMENSION(no_of_signals) :: handler_ptr_array - -!---------------------------------------------------------------------------- -! System_Signal@SignalMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Install a signal handler -! -!# System_Signal -! -! Calling system_signal(NUMBER, HANDLER) causes user-defined -! subroutine HANDLER to be executed when the signal NUMBER is -! caught. The same subroutine HANDLER maybe installed to handle -! different signals. HANDLER takes only one integer argument which -! is assigned the signal number that is caught. See sample program -! below for illustration. -! -! Calling system_signal(NUMBER) installs a do-nothing handler. This -! is not equivalent to ignoring the signal NUMBER though, because -! the signal can still interrupt any sleep or idle-wait. -! -! Note that the signals SIGKILL and SIGSTOP cannot be handled -! this way. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Signal_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Signal(signum, handler_routine) - INTEGER, INTENT(in) :: signum - PROCEDURE(handler), OPTIONAL :: handler_routine - TYPE(C_FUNPTR) :: ret, c_handler - END SUBROUTINE System_Signal -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Access@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Check accessibility or existence of a pathname -! -!# System_Access -! -! The system_access(3f) function checks pathname existence and access -! permissions. The function checks the pathname for accessibility -! according to the bit pattern contained in amode, using the real user -! ID in place of the effective user ID and the real group ID in place -! of the effective group ID. -! -! The value of amode is either the bitwise-inclusive OR of the access -! permissions to be checked (R_OK, W_OK, X_OK) or the existence test (F_OK). -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Access_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Access(pathname, amode) - CHARACTER(len=*), INTENT(IN) :: pathname - !! a character string representing a directory pathname. - !! Trailing spaces are ignored. - INTEGER, INTENT(IN) :: amode - !! bitwise-inclusive OR of the values R_OK, W_OK, X_OK, or F_OK. - LOGICAL :: System_Access - !! Return value: If not true an error occurred or - !! the requested access is not granted - END FUNCTION System_Access -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Utime@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Set file access and modification times -! -!# System_Utime -! -! The system_utime(3f) function sets the access and modification -! times of the file named by the path argument by calling utime(3c). -! -! If times() is not present the access and modification times of -! the file shall be set to the current time. -! -! To use system_utime(3f) the effective user ID of the process must -! match the owner of the file, or the process has to have write -! permission to the file or have appropriate privileges, -! -!## Errors -! -!The underlying utime(3c) function fails if: -! -!### EACCES -! -! Search permission is denied by a component of the path -! prefix; or the times argument is a null pointer and the -! effective user ID of the process does not match the owner -! of the file, the process does not have write permission -! for the file, and the process does not have appropriate -! privileges. -! -!### ELOOP -! -! A loop exists in symbolic links encountered during -! resolution of the path argument. -! -!### ENAMETOOLONG -! -! The length of a component of a pathname is longer than {NAME_MAX}. -! -!### ENOENT -! -! A component of path does not name an existing file or path is an -! empty string. -! -!### ENOTDIR -! -! A component of the path prefix names an existing file -! that is neither a directory nor a symbolic link to a -! directory, or the path argument contains at least one -! non- character and ends with one or more trailing -! characters and the last pathname component -! names an existing file that is neither a directory nor -! a symbolic link to a directory. -! -!### EPERM -! -! The times argument is not a null pointer and the effective -! user ID of the calling process does not match the owner -! of the file and the calling process does not have -! appropriate privileges. -! -!### EROFS -! -! The file system containing the file is read-only. -! -!## Note -! -! The utime() function may fail if: -! -!- ELOOP More than {SYMLOOP_MAX} symbolic links were encountered -!during resolution of the path argument. -! -!- ENAMETOOLONG The length of a pathname exceeds {PATH_MAX}, or -! pathname resolution of a symbolic link produced -! an intermediate result with a length that exceeds -! {PATH_MAX}. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Utime_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Utime(pathname, times) - CHARACTER(len=*), INTENT(in) :: pathname - !!name of the file whose access and modification times are to be updated. - INTEGER, INTENT(in), OPTIONAL :: times(2) - !! If present, the values will be interpreted as the access - !! and modification times as Unix Epoch values. That is, - !! they are times measured in seconds since the Unix Epoch. - LOGICAL :: System_Utime - !! Upon successful completion .TRUE. is returned. Otherwise, - !! .FALSE. is returned and errno shall be set to indicate the error, - !! and the file times remain unaffected. - END FUNCTION System_Utime -END INTERFACE - -!---------------------------------------------------------------------------- -! System_RealPath@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Resolve the relative path -! -!# System_Realpath -! -! system_realpath(3f) calls the C routine realpath(3c) to obtain -! the absolute pathname of given path -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Realpath_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Realpath(input) RESULT(string) - CHARACTER(*), INTENT(in) :: input - !! pathname to resolve - CHARACTER(:), ALLOCATABLE :: string - !! The absolute pathname of the given input pathname. - !! The pathname shall contain no components that are dot - !! or dot-dot, or are symbolic links. It is equal to the - !! NULL character if an error occurred. - END FUNCTION System_Realpath -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: checks if argument is a socket -! -!# System_Issock -! -! The issock(3f) function checks if path is a path to a socket - -INTERFACE - MODULE FUNCTION System_Issock(pathname) - CHARACTER(*), INTENT(IN) :: pathname - !! a character string representing a socket pathname. - !! Trailing spaces are ignored. - LOGICAL :: System_Issock - !! The system_issock() function should always be successful and no - !! return value is reserved to indicate an error. - END FUNCTION System_Issock -END INTERFACE - -!---------------------------------------------------------------------------- -! C2F_String@UtilityMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: converts c string to fortran string - -INTERFACE - MODULE FUNCTION C2F_String(c_string_pointer) RESULT(f_string) - TYPE(C_PTR), INTENT(IN) :: c_string_pointer - CHARACTER(:), ALLOCATABLE :: f_string - END FUNCTION C2F_String -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Str2_Carr - -INTERFACE - MODULE PURE FUNCTION str2_carr(string) RESULT(array) - CHARACTER(*), INTENT(in) :: string - CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) - END FUNCTION str2_carr -END INTERFACE - -!---------------------------------------------------------------------------- -! TimeStamp@UtilityMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Time stamp method - -INTERFACE - MODULE FUNCTION TimeStamp() RESULT(epoch) - INTEGER(kind=8) :: epoch - END FUNCTION TimeStamp -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Isfifo@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: check if argument is a fifo named pipe -! -!# System_Isfifo -! -! Check if argument is a fifo named pipe. - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Isfifo(pathname) - CHARACTER(len=*), INTENT(in) :: pathname - !! a character string representing a fifo - named pipe pathname. - !! Trailing spaces are ignored. - LOGICAL :: System_Isfifo - !! The system_isfifo() function should always be successful and no - !! return value is reserved to indicate an error. - END FUNCTION System_Isfifo -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Ischr@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: checks if argument is a character device -! -!# System_Ischr -! -! The ischr(3f) function checks if path is a path to a character device. - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Ischr(pathname) - CHARACTER(*), INTENT(IN) :: pathname - !! a character string representing a character device pathname. - !! Trailing spaces are ignored. - LOGICAL :: System_Ischr - !! The system_ischr() function should always be successful and no - !! return value is reserved to indicate an error. - END FUNCTION System_Ischr -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Isreg@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: checks if argument is a regular file -! -!# System_Isreg -! -! The isreg(3f) function checks if path is a regular file -! -!## Examples 1 -! -!```fortran -! {{% fortran-code file="examples/System_Isreg_test_1.F90" %}} -!``` -! -!## Examples 2 -! -!```fortran -! {{% fortran-code file="examples/System_Isreg_test_2.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL impure FUNCTION System_Isreg(pathname) - CHARACTER(*), INTENT(IN) :: pathname - !! a character string representing a pathname. - !! Trailing spaces are ignored. - LOGICAL :: System_Isreg - !! The system_isreg() function should always be successful and no - !! return value is reserved to indicate an error. - END FUNCTION System_Isreg -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Islnk@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: checks if argument is a link -! -!# System_Islnk -! -! The islnk(3f) function checks if path is a path to a link. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Islink_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Islnk(pathname) - CHARACTER(len=*), INTENT(in) :: pathname - !! a character string representing a link - !! pathname. Trailing spaces are ignored. - LOGICAL :: System_Islnk - !! The system_islnk() function should always be - !! successful and no return value is reserved to - !! indicate an error. - END FUNCTION System_Islnk -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Isblk@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Check if argument is a block device -! -!# System_Isblk -! -! The isblk(3f) function checks if path is a path to a block device. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Isblk_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Isblk(pathname) - CHARACTER(*), INTENT(IN) :: pathname - !! a character string representing a block device pathname. - !! Trailing spaces are ignored. - LOGICAL :: System_Isblk - !! The system_isblk() function should always be successful and no - !! return value is reserved to indicate an error. - END FUNCTION System_Isblk -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Isdir@EnquiryMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: checks if argument is a directory of not -! -!# System_Isdir -! -! The system_isdir(3f) function checks if path is a directory. -! -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Isdir_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Isdir(dirname) - CHARACTER(len=*), INTENT(in) :: dirname - !! a character string representing a directory pathname. - !! Trailing spaces are ignored. - LOGICAL :: System_Isdir - !! The system_isdir() function should always be successful and no - !! return value is reserved to indicate an error. - END FUNCTION System_Isdir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Chown@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: change file owner and group -! -!# System_Chown -! -! Elemental impure logical function system_chown(path,owner,group) -! -! The chown(3f) function changes owner and group of a file -! -! The path argument points to a pathname naming a file. The -! user ID and group ID of the named file shall be set to the numeric -! values contained in owner and group, respectively. -! -! Only processes with an effective user ID equal to the user ID of -! the file or with appropriate privileges may change the ownership -! of a file. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Chown_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Chown(dirname, owner, group) - CHARACTER(*), INTENT(IN) :: dirname - !! A character string representing a file pathname. - !! Trailing spaces are ignored. - INTEGER, INTENT(IN) :: owner - !! UID of owner that ownership is to be changed to - INTEGER, INTENT(IN) :: group - !! GID of group that ownership is to be changed to - LOGICAL :: System_Chown - !! The system_chown(3f) function should return zero 0 if successful. - !! Otherwise, these functions shall return 1 and set errno to - !! indicate the error. If 1 is returned, no changes are made in - !! the user ID and group ID of the file. - END FUNCTION System_Chown -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get processor time by calling times -! -!# System_Cpu_Time -! -! Get processor time by calling times -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Cpu_Time" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Cpu_Time(total, user, system) - REAL, INTENT(OUT) :: user, system, total - !! C_Total total processor time ( C_User + C_System ) - !! C_User processor user time - !! C_System processor system time - END SUBROUTINE System_Cpu_Time -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Link@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: link one file to another file relative to two directory -! descriptors -! -!# System_Link -! -! The link() function shall create a new link (directory entry) -! for the existing file, path1. -! -! The path1 argument points to a pathname naming an existing -! file. The path2 argument points to a pathname naming the -! new directory entry to be created. The link() function shall -! atomically create a new link for the existing file and the link -! count of the file shall be incremented by one. -! -! If path1 names a directory, link() shall fail unless the process -! has appropriate privileges and the implementation supports using -! link() on directories. -! -! If path1 names a symbolic link, it is implementation-defined -! whether link() follows the symbolic link, or creates a new link -! to the symbolic link itself. -! -! Upon successful completion, link() shall mark for update the -! last file status change timestamp of the file. Also, the last -! data modification and last file status change timestamps of the -! directory that contains the new entry shall be marked for update. -! -! If link() fails, no link shall be created and the link count of -! the file shall remain unchanged. -! -! The implementation may require that the calling process has -! permission to access the existing file. -! -! The linkat() function shall be equivalent to the link() function -! except that symbolic links shall be handled as specified by the -! value of flag (see below) and except in the case where either path1 -! or path2 or both are relative paths. In this case a relative path -! path1 is interpreted relative to the directory associated with -! the file descriptor fd1 instead of the current working directory -! and similarly for path2 and the file descriptor fd2. If the -! file descriptor was opened without O_SEARCH, the function shall -! check whether directory searches are permitted using the current -! permissions of the directory underlying the file descriptor. If -! the file descriptor was opened with O_SEARCH, the function shall -! not perform the check. -! -! Values for flag are constructed by a bitwise-inclusive OR of -! flags from the following list, defined in : -! -! AT_SYMLINK_FOLLOW -! If path1 names a symbolic link, a new link for the target -! of the symbolic link is created. -! -! If linkat() is passed the special value AT_FDCWD in the fd1 or -! fd2 parameter, the current working directory shall be used for the -! respective path argument. If both fd1 and fd2 have value AT_FDCWD, -! the behavior shall be identical to a call to link(), except that -! symbolic links shall be handled as specified by the value of flag. -! -! Some implementations do allow links between file systems. -! -! If path1 refers to a symbolic link, application developers should -! use linkat() with appropriate flags to select whether or not the -! symbolic link should be resolved. -! -! If the AT_SYMLINK_FOLLOW flag is clear in the flag argument and -! the path1 argument names a symbolic link, a new link is created -! for the symbolic link path1 and not its target. - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Link(oldname, newname) RESULT(ierr) - CHARACTER(len=*), INTENT(IN) :: oldname - CHARACTER(len=*), INTENT(IN) :: newname - INTEGER :: ierr - !! Upon successful completion, these functions shall return - !! 0. Otherwise, these functions shall return -1 and set errno to - !! indicate the error. - END FUNCTION System_Link -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Unlink@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: remove a directory entry relative to directory file descriptor -! -!# System_Unlink -! -! The unlink() function shall remove a link to a file. If path names a -! symbolic link, unlink() shall remove the symbolic link named by path -! and shall not affect any file or directory named by the contents of -! the symbolic link. Otherwise, unlink() shall remove the link named by -! the pathname pointed to by path and shall decrement the link count of -! the file referenced by the link. -! -! When the files link count becomes 0 and no process has the file open, -! the space occupied by the file shall be freed and the file shall no -! longer be accessible. If one or more processes have the file open when -! the last link is removed, the link shall be removed before unlink() -! returns, but the removal of the file contents shall be postponed until -! all references to the file are closed. -! -! The path argument shall not name a directory unless the process has -! appropriate privileges and the implementation supports using unlink() -! on directories. -! -! Upon successful completion, unlink() shall mark for update the last -! data modification and last file status change timestamps of the parent -! directory. Also, if the file link count is not 0, the last file status -! change timestamp of the file shall be marked for update. -! -! Values for flag are constructed by a bitwise-inclusive OR of flags from -! the following list, defined in : -! -! AT_REMOVEDIR -! -! Remove the directory entry specified by fd and path as a -! directory, not a normal file. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Unlink_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Unlink(fname) RESULT(ierr) - CHARACTER(len=*), INTENT(in) :: fname - INTEGER :: ierr - !! Upon successful completion, these functions shall return 0. Otherwise, - !! these functions shall return -1 and set errno to indicate the error. - !! If -1 is returned, the named file shall not be changed. - END FUNCTION System_Unlink -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Setumask@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Set the file mode creation umask -! -!# System_Setumask -! -! The `system_umask(3f)` function sets the file mode creation mask of -! the calling process to `cmask` and returns the previous value of -! the mask. -! -! Only the file permission bits of `cmask` (see ``) are -! used. The interpretation of any other bits is -! implementation-defined. -! -!### Effect of the file creation mask -! -! The file mode creation mask is applied to the `mode` argument -! supplied to the following functions: -! -! - `open()`, `openat()`, `creat()` -! - `mkdir()`, `mkdirat()`, `mkfifo()`, `mkfifoat()` -! - `mknod()`, `mknodat()` -! - `mq_open()` -! - `sem_open()` -! -!## Semantics -! -! - Bit positions that are set in `cmask` are cleared in the `mode` -! of any subsequently created file or object. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Setumask_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Setumask(Umask_Value) RESULT(Old_Umask) - INTEGER, INTENT(in) :: Umask_Value - INTEGER :: Old_Umask - !! The file permission bits in the value returned by umask() shall be - !! the previous value of the file mode creation mask. The state of any - !! other bits in that value is unspecified, except that a subsequent - !! call to umask() with the returned value as cmask shall leave the - !! state of the mask the same as its state before the first call, - !! including any unspecified use of those bits. - END FUNCTION System_Setumask -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getumask@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get current umask -! -!# System_Getumask -! -! The return value from getumask(3f) is the value of the file -! creation mask, obtained by using umask(3c). -! -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Getumask_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Getumask() RESULT(Umask_Value) - INTEGER :: Umask_Value - !! The return value from umask() is just the previous value of the file - !! creation mask, so that this system call can be used both to get and - !! set the required values. Sadly, however, - !! there is no way to get the old - !! umask value without setting a new value at the same time. - !! This means that in order just to see the current value, - !! it is necessary - !! to execute a piece of code like the following function: - END FUNCTION System_Getumask -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Perror@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: print error message for last C error on stderr -! -!# System_Perror -! -! Use system_perror(3f) to print an error message on stderr -! corresponding to the current value of the C global variable errno. -! Unless you use NULL as the argument prefix, the error message will -! begin with the prefix string, followed by a colon and a space -! (:). The remainder of the error message produced is one of the -! strings described for strerror(3c). -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Perror_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Perror(prefix) - CHARACTER(len=*), INTENT(IN) :: prefix - END SUBROUTINE System_Perror -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Chdir@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: change working directory -! -!# System_Chdir -! -! The `system_chdir(3f)` procedure changes the current working directory -! of the calling process to the directory specified by `path`. -! -! The current working directory is used as the starting point for -! interpreting relative pathnames (those not beginning with `/`). -! -!## Errors -! -! On failure, an error condition is reported as described below. The -! specific error returned may depend on the underlying file system. -! -! The following errors correspond to the C `chdir()` definitions: -! -! - `EACCES` -! Search permission is denied for one of the components of `path`. -! See also `path_resolution(7)`. -! -! - `EFAULT` -! `path` points outside the accessible address space. -! -! - `EIO` -! An I/O error occurred. -! -! - `ELOOP` -! Too many symbolic links were encountered while resolving `path`. -! -! - `ENAMETOOLONG` -! `path` is too long. -! -! - `ENOENT` -! The specified file does not exist. -! -! - `ENOMEM` -! Insufficient kernel memory was available. -! -! - `ENOTDIR` -! A component of `path` is not a directory. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Chdir_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Chdir(path, err) - CHARACTER(len=*), INTENT(IN) :: path - INTEGER, OPTIONAL, INTENT(OUT) :: err - !! On success, zero is returned. On error, -1 is returned, and errno is - !! set appropriately. - END SUBROUTINE System_Chdir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Remove@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: remove a file -! -!# System_Remove -! -! Fortran supports scratch files via the OPEN(3c) command; but does -! not otherwise allow for removing files. The system_remove(3f) command -! allows for removing files by name that the user has the authority to -! remove by calling the C remove(3c) function. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Remove_test_1.F90" %}} -!``` - -INTERFACE - MODULE ELEMENTAL IMPURE FUNCTION System_Remove(path) RESULT(err) - CHARACTER(*), INTENT(in) :: path - INTEGER(C_INT) :: err - END FUNCTION System_Remove -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Rename@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: rename a system file -! -!# System_Rename -! -! Rename a file by calling rename(3c). It is not recommended that the -! rename occur while either filename is being used on a file currently -! OPEN(3f) by the program. -! Both the old and new names must be on the same device. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Rename_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Rename(input, output) RESULT(ierr) - CHARACTER(*), INTENT(IN) :: input, output - !! system filename of an existing file to rename - !! system filename to be created or overwritten by INPUT file. - !! Must be on the same device as the INPUT file. - INTEGER :: ierr - !! zero (0) if no error occurs. If not zero a call to - !! system_errno(3f) or system_perror(3f) is supported - !! to diagnose error - END FUNCTION System_Rename -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: call chmod(3c) to change permission mode of a file -! relative to directory file descriptor -! -!# System_Chmod -! -! The `system_chmod(3f)` function changes the `S_ISUID`, `S_ISGID`, -! `S_ISVTX`, and file permission bits of the file specified by `path` -! to the corresponding bits in the `mode` argument. -! -! The application shall ensure that the effective user ID of the -! calling process matches the owner of the file, or that the process -! has sufficient privileges. -! -! The constants `S_ISUID`, `S_ISGID`, `S_ISVTX`, and the file -! permission bits are defined in ``. -! -!## Privilege and group semantics -! -! - If the calling process lacks appropriate privileges, and -! the group ID of the file does not match the effective group ID -! or any supplementary group ID, then `S_ISGID` is cleared on -! successful return when the file is a regular file. -! -! - Additional implementation-defined restrictions may cause the -! `S_ISUID` and `S_ISGID` bits in `mode` to be ignored. -! -!## Timestamps -! -! - Upon successful completion, `system_chmod()` marks the last -! file status change timestamp of the file for update. -! -!## Flags -! -! Values for `flag` are constructed using a bitwise-inclusive OR of -! the following values defined in ``: -! -! - `AT_SYMLINK_NOFOLLOW` -! If `path` names a symbolic link, the mode of the symbolic link -! itself is changed rather than the target. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Chmod_test_1.F90" %}} -!``` -! -INTERFACE - MODULE FUNCTION System_Chmod(filename, mode) RESULT(ierr) - CHARACTER(*), INTENT(IN) :: filename - INTEGER, VALUE, INTENT(IN) :: mode - INTEGER :: ierr - !! Upon successful completion, system_chmod(3f) returns 0. - !! Otherwise, it returns -1 and sets errno to indicate the error. If - !! -1 is returned, no change to the file mode occurs. - END FUNCTION System_Chmod -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getcwd@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get current working directory -! -!# System_Getcwd -! -! Get current working directory -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Getcwd_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Getcwd(output, ierr) - CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: output - !! The absolute pathname of the current working directory - !! The pathname shall contain no components that are dot or dot-dot, - !! or are symbolic links. - INTEGER, INTENT(out) :: ierr - !! ierr is not zero if an error occurs. - END SUBROUTINE System_Getcwd -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Rmdir@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: remove empty directories -! -!# System_Rmdir -! -! Remove empty directories. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Rmdir_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Rmdir(dirname) RESULT(err) - CHARACTER(*), INTENT(IN) :: dirname - !! The name of a directory to remove if it is empty - INTEGER(C_INT) :: err - !! zero (0) if no error occurred - END FUNCTION System_Rmdir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Mkfifo@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: make a FIFO special file relative to directory file descriptor -! -!# System_Mkfifo -! -! A regular pipe can only connect two related processes. It is created -! by a process and vanishes when the last process closes it. -! -! A named pipe, also known as a FIFO, can connect two unrelated -! processes and exists independently of the processes using it. -! A FIFO is created using the `mkfifo()` library function. -! -!## Behavior and semantics -! -! - `mkfifo()` creates a new FIFO special file specified by `pathname`. -! - The file permission bits of the new FIFO are initialized from -! `mode`. -! - The permission bits specified in `mode` are modified by the -! process file creation mask. -! - If bits other than file permission bits are set in `mode`, -! the effect is implementation-defined. -! - If `pathname` names a symbolic link, `mkfifo()` fails and sets -! `errno` to `EEXIST`. -! - The FIFO user ID is set to the effective user ID of the process. -! - The FIFO group ID is set either to the group ID of the parent -! directory or to the effective group ID of the process. -! - Implementations shall provide a method to initialize the FIFO -! group ID from the parent directory. -! - Implementations may optionally provide a method to initialize -! the FIFO group ID from the effective group ID of the caller. -! - Upon successful completion, the FIFO last access, modification, -! and status change timestamps are marked for update. -! - The directory containing the new FIFO also has its modification -! and status change timestamps updated. -! -!## Permission modes -! -! Predefined variables are typically used to specify permission modes. -! These variables may be combined using a bytewise OR operation. -! -! Permission bits by category: -! -! - **User** -! - `R_USR` : read -! - `W_USR` : write -! - `X_USR` : execute -! -! - **Group** -! - `R_GRP` : read -! - `W_GRP` : write -! - `X_GRP` : execute -! -! - **Others** -! - `R_OTH` : read -! - `W_OTH` : write -! - `X_OTH` : execute -! -!## Shortcut constants -! -! The following predefined constants represent common combinations: -! -! - `RWX_U` : read, write, execute for user -! - `RWX_G` : read, write, execute for group -! - `RWX_O` : read, write, execute for others -! - `DEFFILEMODE` -! Equivalent to octal `0666` (`rw-rw-rw-`) -! - `ACCESSPERMS` -! Equivalent to octal `0777` (`rwxrwxrwx`) -! -!## Examples -! -! To grant read, write, and execute permissions only to the user: -! -! - `ierr = mkfifo("myfile", IANY([R_USR, W_USR, X_USR]))` -! - `ierr = mkfifo("myfile", RWX_U)` -! -! To grant full permissions to all users (mode `0777`): -! -! - `ierr = mkfifo("myfile", IANY([R_USR, W_USR, X_USR, R_GRP, W_GRP, & -! X_GRP, R_OTH, W_OTH, X_OTH]))` -! - `ierr = mkfifo("myfile", IANY([RWX_U, RWX_G, RWX_O]))` -! - `ierr = mkfifo("myfile", ACCESSPERMS)` -! -!```fortran -! {{% fortran-code file="examples/System_Mkfifo_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Mkfifo(pathname, mode) RESULT(err) - CHARACTER(*), INTENT(IN) :: pathname - INTEGER, INTENT(IN) :: mode - INTEGER :: err - !! Upon successful completion, return 0. - !! Otherwise, return -1 and set errno to indicate the error. - !! If -1 is returned, no FIFO is created. - END FUNCTION System_Mkfifo -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Mkdir@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: call mkdir(3c) to create a new directory -! -!# System_Mkdir -! -! Predefined variables are typically used to set permission modes. -! These variables can be combined using a bytewise OR operation to -! create commonly used permission settings. -! -! Permission bits by category: -! -! - **User** -! - `R_USR` : read -! - `W_USR` : write -! - `X_USR` : execute -! -! - **Group** -! - `R_GRP` : read -! - `W_GRP` : write -! - `X_GRP` : execute -! -! - **Others** -! - `R_OTH` : read -! - `W_OTH` : write -! - `X_OTH` : execute -! -! Additional shortcut constants are provided. These are predefined -! bitwise-OR combinations of the permission flags listed above: -! -! - `RWX_U` : read, write, and execute for user -! - `RWX_G` : read, write, and execute for group -! - `RWX_O` : read, write, and execute for others -! - `DEFFILEMODE` -! Equivalent to octal `0666` (`rw-rw-rw-`) -! - `ACCESSPERMS` -! Equivalent to octal `0777` (`rwxrwxrwx`) -! -! To grant only the user read, write, and execute permissions, while -! denying all permissions to group members and others, any of the -! following `mkdir()` calls may be used equivalently: -! -! - `ierr = mkdir("mydir", IANY([R_USR, W_USR, X_USR]))` -! - `ierr = mkdir("mydir", RWX_U)` -! -! To grant full permissions to all users (mode `0777`, `rwxrwxrwx`), -! any of the following calls may be used equivalently: -! -! - `ierr = mkdir("mydir", IANY([R_USR, W_USR, X_USR, R_GRP, W_GRP, X_GRP, & -! R_OTH, W_OTH, X_OTH]))` -! - `ierr = mkdir("mydir", IANY([RWX_U, RWX_G, RWX_O]))` -! - `ierr = mkdir("mydir", ACCESSPERMS)` -! -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Mkdir_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Mkdir(dirname, mode) RESULT(ierr) - CHARACTER(len=*), INTENT(in) :: dirname - INTEGER, INTENT(in) :: mode - INTEGER :: ierr - END FUNCTION System_Mkdir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Opendir@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: open directory stream by calling opendir -! -!# System_Opendir -! -! The `system_opendir(3f)` procedure opens a directory stream that -! corresponds to the directory specified by the `dirname` argument. -! -! The directory stream is positioned at the first directory entry. -! -!## Return value -! -! - Upon successful completion, a pointer to a C `DIR` type is returned. -! -! - On failure, a null pointer is returned and `IERR` is set to indicate -! the error condition. -! -!## Errors -! -! Errors correspond to the conditions described for `opendir(3c)`, -! including the following: -! -! - `EACCES` -! Search permission is denied for a component of the path prefix of -! `dirname`, or read permission is denied for `dirname`. -! -! - `ELOOP` -! A loop exists in symbolic links encountered during resolution of -! the `dirname` argument. -! -! - `ENAMETOOLONG` -! The length of a pathname component exceeds `{NAME_MAX}`. -! -! - `ENOENT` -! A component of `dirname` does not name an existing directory, or -! `dirname` is an empty string. -! -! - `ENOTDIR` -! A component of `dirname` names an existing file that is neither a -! directory nor a symbolic link to a directory. -! -! - `ELOOP` -! More than `{SYMLOOP_MAX}` symbolic links were encountered during -! resolution of the `dirname` argument. -! -! - `EMFILE` -! All file descriptors available to the process are currently open. -! -! - `ENAMETOOLONG` -! The length of a pathname exceeds `{PATH_MAX}`, or pathname -! resolution of a symbolic link produced an intermediate result whose -! length exceeds `{PATH_MAX}`. -! -! - `ENFILE` -! Too many files are currently open in the system. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Opendir_test_1.F90" %}} -!``` -! -INTERFACE - MODULE SUBROUTINE System_Opendir(dirname, dir, ierr) - CHARACTER(len=*), INTENT(IN) :: dirname - !! name of directory to open a directory stream for - TYPE(C_PTR), INTENT(INOUT) :: dir - !! pointer to directory stream. If an - !! error occurred, it will not be associated. - INTEGER, INTENT(OUT) :: ierr - !! ierr 0 indicates no error occurred - END SUBROUTINE System_Opendir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Readdir@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Read a directory -! -!# System_Readdir -! -! system_readdir(3f) returns the name of the directory entry at the -! current position in the directory stream specified by the argument -! DIR, and positions the directory stream at the next entry. It returns -! a null name upon reaching the end of the directory stream. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Readdir_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Readdir(dir, filename, ierr) - TYPE(C_PTR), VALUE :: dir - !! A pointer to the directory opened by system_opendir(3f). - CHARACTER(len=:), INTENT(out), ALLOCATABLE :: filename - !! the name of the directory entry at the current position in - !! the directory stream specified by the argument DIR, and - !! positions the directory stream at the next entry. - !! The readdir() function does not return directory entries - !! containing empty names. If entries for dot or dot-dot exist, - !! one entry is returned for dot and one entry is returned - !! for dot-dot. - !! The entry is marked for update of the last data access - !! timestamp each time it is read. - !! reaching the end of the directory stream, the name is a blank name. - INTEGER, INTENT(out) :: ierr - !! If IERR is set to non-zero on return, an error occurred. - END SUBROUTINE System_Readdir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Rewinddir@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Rewind directory stream -! -!# System_Rewinddir -! -! Return to pointer to the beginning of the list for a currently open -! directory list. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Rewinddir_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Rewinddir(dir) - TYPE(C_PTR), VALUE :: dir - !! A C_Pointer assumed to have been allocated by a - !! call to SYSTEM_OPENDIR(3f). - END SUBROUTINE System_Rewinddir -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Close a directory stream by calling closedir -! -!# System_Closedir -! -! The SYSTEM_CLOSEDIR(3f) function closes the directory stream -! referred to by the argument DIR. Upon return, the value of DIR may no -! longer point to an accessible object. -! -! system_closedir(3f) may fail if: -! -!- EBADF: The dirp argument does not refer to an open directory stream. -!- EINTR: The closedir() function was interrupted by a signal. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Closedir_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Closedir(dir, ierr) - TYPE(C_PTR), VALUE :: dir - !! directory stream pointer opened by SYSTEM_OPENDIR(3f). - INTEGER, INTENT(out), OPTIONAL :: ierr - !! Upon successful completion, SYSTEM_CLOSEDIR(3f) returns 0; - !! otherwise, an error has occurred. - END SUBROUTINE System_Closedir -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Putenv@EnvironmentMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Set environment variable from Fortran -! -!# System_Putenv -! -! The system_putenv() function adds or changes the value -! of environment variables. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Putenv_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Putenv(string, err) - CHARACTER(len=*), INTENT(in) :: string - !! string of format "NAME=value". - !! If name does not already exist in the environment, - !! then string is added to the environment. - !! If name does exist, then the value of name in the environment is - !! changed to value. - !! The string passed to putenv(3c) becomes part of the environment, - !! so this routine creates a string each time it is called that - !! increases the amount of - !! memory the program uses. - INTEGER, OPTIONAL, INTENT(out) :: err - !! The system_putenv() function returns zero on success, - !! or nonzero if an error occurs. - !! A non-zero error usually indicates sufficient memory - !! does not exist to store the - !! variable. - END SUBROUTINE System_Putenv -END INTERFACE - -!---------------------------------------------------------------------------- -! arr2str@UtilityMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-07 -! summary: convert fortran array to a string - -INTERFACE - MODULE PURE FUNCTION arr2str(array) RESULT(string) - CHARACTER(len=1), INTENT(IN) :: array(:) - CHARACTER(len=SIZE(array)) :: string - END FUNCTION arr2str -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getenv@EnvironmentMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: get environment variable -! -!# System_Getenv -! -! The system_getenv() function gets the value of an environment variable. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Getenv_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Getenv(name, default) RESULT(VALUE) - CHARACTER(*), INTENT(IN) :: name - !! Return the value of the specified environment variable or - !! blank if the variable is not defined. - CHARACTER(*), INTENT(IN), OPTIONAL :: default - !! If the value returned would be blank this value will be used - !! instead. - CHARACTER(:), ALLOCATABLE :: VALUE - END FUNCTION System_Getenv -END INTERFACE - -!---------------------------------------------------------------------------- -! Set_Environment_Variable@EnvironmentMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: call setenv(3c) to set environment variable -! -!# Set_Environment -! -! The set_environment_variable() procedure adds or changes the value of -! environment variables. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/Set_Environment_Variable_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE Set_Environment_Variable(NAME, VALUE, STATUS) - CHARACTER(*), INTENT(IN) :: NAME - !! If name does not already exist in the environment, - !! then string is added to the environment. - !! If name does exist, then the value of name in the environment - !! is changed to value. - CHARACTER(*), INTENT(IN) :: VALUE - !! Value to assign to environment variable NAME - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS - !! returns zero on success, or nonzero if an error occurs. - !! A non-zero error usually indicates sufficient memory does - !! not exist to store the - !! variable. - END SUBROUTINE Set_Environment_Variable -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Clearenv@EnvironmentMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Clear environment by calling clearenv(3c) -! -!# System_Clearenv -! -! The System_Clearenv() procedure clears the environment of all name-value -! pairs. Typically used in security-conscious applications or ones where -! configuration control requires ensuring specific variables are set. -! -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Clearenv_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Clearenv(ierr) - INTEGER, INTENT(OUT), OPTIONAL :: ierr - !! returns zero on success, and a nonzero value on failure. Optional. - !! If not present and an error occurs the program stops. - END SUBROUTINE System_Clearenv -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Unsetenv@EnvironmentMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: delete an environment variable by calling unsetenv(3c) -! -!# System_Unsetenv -! -! The System_Unsetenv(3f) function deletes the variable name from the -! environment. - -INTERFACE - MODULE SUBROUTINE System_Unsetenv(name, ierr) - CHARACTER(len=*), INTENT(in) :: name - !! name of variable to delete. - !! If name does not exist in the environment, then the - !! function succeeds, and the environment is unchanged. - INTEGER, INTENT(out), OPTIONAL :: ierr - !! The system_unsetenv(3f) function returns zero on success, - !! or -1 on error. - !! name is NULL, points to a string of length 0, or - !! contains an '=' character. - !! Insufficient memory to add a new variable to the environment. - END SUBROUTINE System_Unsetenv -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Readenv@EnvironmentMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: step thru and read environment table -! -! ## System_Readenv -! -! This routine provides a simple interface for reading the environment -! variable table of the current process. -! -! The recommended usage pattern is as follows: -! -! - Call `system_initenv(3f)` to initialize access to the environment -! table. -! -! - Repeatedly call `system_readenv(3f)` to read entries from the -! environment table. -! -! - Reading terminates when a blank line is returned. -! -! ### Notes -! -! - If more than one thread reads the environment simultaneously, the -! results are undefined. -! -! - If the environment is modified while it is being read, the results -! are also undefined. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Readenv_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Readenv() RESULT(string) - CHARACTER(len=:), ALLOCATABLE :: string - !! the string returned from the environment of the form "NAME=VALUE" - END FUNCTION System_Readenv -END INTERFACE - -!---------------------------------------------------------------------------- -! Fileglob@FileMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Read output of an ls(1) command from Fortran -! -!# Fileglob -! -! Non-portable procedure uses the shell and the ls(1) command -! to expand a filename -! and returns a pointer to a list of expanded filenames. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/Fileglob_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE Fileglob(glob, list) - CHARACTER(*), INTENT(IN) :: glob - !! Pattern for the filenames (like: *.txt) - CHARACTER(*), POINTER, INTENT(INOUT) :: list(:) - !! Allocated list of filenames (returned), the caller must deallocate it. - END SUBROUTINE Fileglob -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getuname@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get current system information -! -! ## System_Getuname -! -! Given a single-character selector, this routine returns the corresponding -! description of the current operating system. -! -! The `NAMEOUT` variable is assumed to be sufficiently large to hold the -! returned value. -! -! The following selector values are supported: -! -! - `s` Returns the kernel name. -! - `r` Returns the kernel release. -! - `v` Returns the kernel version. -! - `n` Returns the network node hostname. -! - `m` Returns the machine hardware name. -! - `T` Test mode: prints all information in the following order: -! `s r v n m`. - -INTERFACE - MODULE SUBROUTINE System_Uname(WHICH, NAMEOUT) - CHARACTER(KIND=C_CHAR), INTENT(IN) :: WHICH - CHARACTER(*), INTENT(OUT) :: NAMEOUT - END SUBROUTINE System_Uname -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Gethostname@Getmethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get name of current host -! -!# System_Gethostname -! -! The system_gethostname(3f) procedure returns the standard host -! name for the current machine. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Gethostname_test_1.F90" %}} -!``` - -INTERFACE - MODULE SUBROUTINE System_Gethostname(NAME, IERR) - CHARACTER(:), ALLOCATABLE, INTENT(OUT) :: NAME - !! string returns the hostname. - INTEGER, INTENT(OUT) :: IERR - !! Upon successful completion, 0 shall be returned; otherwise, -1 - !! shall be returned. - END SUBROUTINE System_Gethostname -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getlogin@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get login name -! -! ## System_Getlogin -! -! The `system_getlogin(3f)` function returns a string containing the user -! name associated with the login activity of the controlling terminal of the -! current process. -! -! If the user name cannot be determined, the function returns a null string -! and sets `errno` to indicate the error. -! -! The following three user names associated with the current process can be -! determined: -! -! - `system_getpwuid(system_getuid())` -! Returns the name associated with the real user ID of the process. -! -! - `system_getpwuid(system_geteuid())` -! Returns the name associated with the effective user ID of the process. -! -! - `system_getlogin()` -! Returns the name associated with the current login activity.!! -!! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Getlogin_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Getlogin() RESULT(fname) - CHARACTER(:), ALLOCATABLE :: fname - END FUNCTION System_Getlogin -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Perm@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get file type and permission as a string -! -!# System_Perm -! -! The system_perm(3f) function returns a string containing the type -! and permission of a file implied by the value of the mode value. -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Perm_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Perm(mode) RESULT(perms) - CLASS(*), INTENT(IN) :: mode - CHARACTER(len=:), ALLOCATABLE :: perms - !! returns the permission string in a format similar to that - !! used by Unix commands such as ls(1). - END FUNCTION System_Perm -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getgrgid@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-06 -! summary: Get groupd name associated with a GID -! -!# System_Getgrgid -! -! The System_Getgrgid() function returns a string containing the group -! name associated with the given GID. If no match is found -! it returns a null string and sets errno to indicate the error. -! -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Getgrgid_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Getgrgid(gid) RESULT(gname) - CLASS(*), INTENT(IN) :: gid - !! GID to try to look up associated group for. Can be of any - !! INTEGER type. - CHARACTER(len=:), ALLOCATABLE :: gname - !! returns the group name. Blank if an error occurs - END FUNCTION System_Getgrgid -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Getpwuid@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Get login name associated with a UID -! -!# System_Getpwuid -! -! The system_getpwuid() function returns a string containing the user -! name associated with the given UID. If no match is found it returns -! a null string and sets errno to indicate the error. -! -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Getpwuid_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Getpwuid(uid) RESULT(uname) - CLASS(*), INTENT(IN) :: uid - !! UID to try to look up associated username for. Can be of any - !! INTEGER type. - CHARACTER(:), ALLOCATABLE :: uname - !! returns the login name. - END FUNCTION System_Getpwuid -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Stat -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Get file status information -! -!# System_Stat -! -! This function returns information about a file. No permissions are -! required on the file itself, but execute (search) permission is required -! on all of the directories in path that lead to the file. The elements -! that are obtained and stored in the array VALUES: -! -! | Index | VALUES(n) | Description | -! |-------|-----------|-------------| -! | 1 | VALUES(1) | Device ID | -! | 2 | VALUES(2) | Inode number | -! | 3 | VALUES(3) | File mode | -! | 4 | VALUES(4) | Number of links | -! | 5 | VALUES(5) | Owner UID | -! | 6 | VALUES(6) | Owner GID | -! | 7 | VALUES(7) | ID of device containing dir entry for file | -! | 8 | VALUES(8) | File size (bytes) | -! | 9 | VALUES(9) | Last access time as a Unix Epoch time (seconds) | -! | 10 | VALUES(10) | Last modification time as a Unix Epoch time (seconds) | -! | 11 | VALUES(11) | Last file status change time as a Unix Epoch time | -! | 12 | VALUES(12) | Preferred I/O block size (-1 if not available) | -! | 13 | VALUES(13) | Number of blocks allocated (-1 if not available) | -! -! > [!NOTE] -! > Not all these elements are relevant on all systems. -! > If an element is not relevant, it is returned as `0`.!! -! -! -!## Examples -! -! ```fortran -! {{% fortran-code file="examples/System_Stat_test_1.F90" %}} -! ``` - -INTERFACE - MODULE SUBROUTINE System_Stat(pathname, values, ierr) - CHARACTER(*), INTENT(IN) :: pathname - !! The type shall be CHARACTER, of the default kind and a valid - !! path within the file system. - INTEGER(INT64), INTENT(OUT) :: values(13) - !! VALUES The type shall be INTEGER(8), DIMENSION(13). - INTEGER, OPTIONAL, INTENT(OUT) :: ierr - END SUBROUTINE System_Stat -END INTERFACE - -!---------------------------------------------------------------------------- -! System_Dir -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Return filenames in a directory matching specific wildcard strings -! -!# System_Dir -! -! returns an array of filenames in the specified directory matching -! the wildcard string (which defaults to "*"). -! -!## Examples -! -!```fortran -! {{% fortran-code file="examples/System_Dir_test_1.F90" %}} -!``` - -INTERFACE - MODULE FUNCTION System_Dir(directory, pattern) - CHARACTER(*), INTENT(IN), OPTIONAL :: directory - !! name of directory to match filenames in. Defaults to ".". - CHARACTER(*), INTENT(IN), OPTIONAL :: pattern - !! wildcard string matching the rules of the matchw(3f) function. - !! Basically "*" matches anything, "?" matches any single character - CHARACTER(:), ALLOCATABLE :: System_Dir(:) - !!System_Dir An array right-padded to the length of the longest - !!filename. Note that this means filenames actually containing - !!trailing spaces in their names may be incorrect. - END FUNCTION System_Dir -END INTERFACE - -!---------------------------------------------------------------------------- -! Matchw@UtilityMethods -!---------------------------------------------------------------------------- - -INTERFACE - MODULE FUNCTION Matchw(tame, wild) - LOGICAL :: Matchw - CHARACTER(*), INTENT(IN) :: tame - !! A string without wildcards - CHARACTER(*), INTENT(IN) :: wild - !! A (potentially) corresponding string with wildcards - END FUNCTION Matchw -END INTERFACE - -!---------------------------------------------------------------------------- -! Anyinteger_to_64bit@UtilityMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: Convert integer any kind to integer -! -!# Anyinteger_to_64bit -! -! This function uses polymorphism to allow arguments of different types -! generically. It is used to create other procedures that can take -! many scalar arguments as input options, equivalent to passing the -! parameter VALUE as INT(VALUE,0_int64). - -INTERFACE - MODULE PURE ELEMENTAL FUNCTION Anyinteger_to_64bit(intin) RESULT(ii38) - CLASS(*), INTENT(in) :: intin - !! Input argument of a procedure to convert to type - !! INTEGER(KIND=int64). May be of KIND kind=int8, kind=int16, - !! kind=int32, kind=int64. - INTEGER(kind=INT64) :: ii38 - !! The value of VALUIN converted to INTEGER(KIND=INT64). - END FUNCTION Anyinteger_to_64bit -END INTERFACE - -!---------------------------------------------------------------------------- -! f_handler@UtilityMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2026-02-05 -! summary: handler - -INTERFACE - MODULE SUBROUTINE f_handler(signum) BIND(c) - INTEGER(C_INT), INTENT(IN), VALUE :: signum - END SUBROUTINE f_handler -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - +USE SystemSignal_Method +USE SystemFile_Method +USE SystemEnvironment_Method +USE SystemEnquiry_Method +USE SystemProcess_Method END MODULE System_Method diff --git a/src/modules/System/src/System_Utility.F90 b/src/modules/System/src/System_Utility.F90 new file mode 100755 index 000000000..a1aecd964 --- /dev/null +++ b/src/modules/System/src/System_Utility.F90 @@ -0,0 +1,142 @@ +! This module is mainly taken from the source: +! https://github.com/urbanjost/M_system. +! The original name of the program has been changed +! from M_SYSTEM to System_Method. +! This is to confirm to the coding sytles of easifem. +! Original program has been re-organized into module and submodule. +! If you are using easifem for getting methods defined in this +! module, then please use M_System module by using the above link. +! We would like to thank the original author Urban Jost for creating +! This useful module. + +!> author: John S. Urban +! date: 2026-02-04 +! summary: Fortran interface to C system interface +! +!# System_Utility +! +! System_Method is a collection of Fortran procedures that call C +! or a C wrapper using the ISO_C_BINDING interface to access system calls. +! System calls are a special set of functions used by programs +! to communicate directly with an operating system. + +MODULE System_Utility +USE ISO_C_BINDING, ONLY: C_INT +USE ISO_C_BINDING, ONLY: C_PTR +USE ISO_C_BINDING, ONLY: C_CHAR +USE GlobalData, ONLY: INT64 +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Anyinteger_to_64bit +PUBLIC :: Matchw +PUBLIC :: Str2_Carr +PUBLIC :: Arr2Str +PUBLIC :: C2F_String +PUBLIC :: TimeStamp + +!---------------------------------------------------------------------------- +! Arr2Str@UtilityMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-07 +! summary: convert fortran array to a string + +INTERFACE + MODULE PURE FUNCTION Arr2Str(array) RESULT(string) + CHARACTER(len=1), INTENT(IN) :: array(:) + CHARACTER(len=SIZE(array)) :: string + END FUNCTION Arr2Str +END INTERFACE + +!---------------------------------------------------------------------------- +! C2F_String@UtilityMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: converts c string to fortran string + +INTERFACE + MODULE FUNCTION C2F_String(c_string_pointer) RESULT(f_string) + TYPE(C_PTR), INTENT(IN) :: c_string_pointer + CHARACTER(:), ALLOCATABLE :: f_string + END FUNCTION C2F_String +END INTERFACE + +!---------------------------------------------------------------------------- +! Str2_Carr@UtilityMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: convert fortran string into c char array. + +INTERFACE + MODULE PURE FUNCTION Str2_Carr(string) RESULT(array) + CHARACTER(*), INTENT(in) :: string + CHARACTER(len=1, kind=C_CHAR) :: array(LEN(string) + 1) + END FUNCTION Str2_Carr +END INTERFACE + +!---------------------------------------------------------------------------- +! TimeStamp@UtilityMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Time stamp method + +INTERFACE + MODULE FUNCTION TimeStamp() RESULT(epoch) + INTEGER(kind=8) :: epoch + END FUNCTION TimeStamp +END INTERFACE + +!---------------------------------------------------------------------------- +! Matchw@UtilityMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE FUNCTION Matchw(tame, wild) + LOGICAL :: Matchw + CHARACTER(*), INTENT(IN) :: tame + !! A string without wildcards + CHARACTER(*), INTENT(IN) :: wild + !! A (potentially) corresponding string with wildcards + END FUNCTION Matchw +END INTERFACE + +!---------------------------------------------------------------------------- +! Anyinteger_to_64bit@UtilityMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2026-02-05 +! summary: Convert integer any kind to integer +! +!# Anyinteger_to_64bit +! +! This function uses polymorphism to allow arguments of different types +! generically. It is used to create other procedures that can take +! many scalar arguments as input options, equivalent to passing the +! parameter VALUE as INT(VALUE,0_int64). + +INTERFACE + MODULE PURE ELEMENTAL FUNCTION Anyinteger_to_64bit(intin) RESULT(ii38) + CLASS(*), INTENT(in) :: intin + !! Input argument of a procedure to convert to type + !! INTEGER(KIND=int64). May be of KIND kind=int8, kind=int16, + !! kind=int32, kind=int64. + INTEGER(INT64) :: ii38 + !! The value of VALUIN converted to INTEGER(KIND=INT64). + END FUNCTION Anyinteger_to_64bit +END INTERFACE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE System_Utility diff --git a/src/submodules/System/CMakeLists.txt b/src/submodules/System/CMakeLists.txt index d323777cc..b2a16bed9 100644 --- a/src/submodules/System/CMakeLists.txt +++ b/src/submodules/System/CMakeLists.txt @@ -17,12 +17,14 @@ # along with this program. If not, see set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") + target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/System_Method@SignalMethods.F90 - PRIVATE ${src_path}/System_Method@EnquiryMethods.F90 - PRIVATE ${src_path}/System_Method@FileMethods.F90 - PRIVATE ${src_path}/System_Method@GetMethods.F90 - PRIVATE ${src_path}/System_Method@UtilityMethods.F90 - PRIVATE ${src_path}/System_Method@EnvironmentMethods.F90 + PRIVATE + ${src_path}/System_Utility@Methods.F90 + ${src_path}/SystemSignal_Method@Methods.F90 + ${src_path}/SystemFile_Method@Methods.F90 + ${src_path}/SystemEnvironment_Method@Methods.F90 + ${src_path}/SystemEnquiry_Method@Methods.F90 + ${src_path}/SystemProcess_Method@Methods.F90 ) diff --git a/src/submodules/System/src/System_Method@EnquiryMethods.F90 b/src/submodules/System/src/SystemEnquiry_Method@Methods.F90 similarity index 51% rename from src/submodules/System/src/System_Method@EnquiryMethods.F90 rename to src/submodules/System/src/SystemEnquiry_Method@Methods.F90 index 4baa561d4..f6f479fec 100644 --- a/src/submodules/System/src/System_Method@EnquiryMethods.F90 +++ b/src/submodules/System/src/SystemEnquiry_Method@Methods.F90 @@ -15,9 +15,19 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -SUBMODULE(System_Method) EnquiryMethods +SUBMODULE(SystemEnquiry_Method) Methods USE ISO_C_BINDING, ONLY: C_SIZE_T USE ISO_C_BINDING, ONLY: C_ASSOCIATED +USE System_Utility, ONLY: Arr2Str +USE System_Utility, ONLY: Str2_Carr +USE SystemInterface, ONLY: C_Access +USE SystemInterface, ONLY: C_Issock +USE SystemInterface, ONLY: C_Isfifo +USE SystemInterface, ONLY: C_Ischr +USE SystemInterface, ONLY: C_Isreg +USE SystemInterface, ONLY: C_Islnk +USE SystemInterface, ONLY: C_Isblk +USE SystemInterface, ONLY: C_Isdir IMPLICIT NONE CONTAINS @@ -27,7 +37,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE System_Access -IF (C_Access(str2_carr(TRIM(pathname)), INT(amode, kind=C_INT)) .EQ. 0) THEN +LOGICAL :: isok + +isok = C_Access(str2_carr(TRIM(pathname)), INT(amode, kind=C_INT)) .EQ. 0 +IF (isok) THEN system_access = .TRUE. ELSE system_access = .FALSE. @@ -39,10 +52,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE System_Issock -IF (c_issock(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_issock = .TRUE. +LOGICAL :: isok + +isok = C_Issock(Str2_Carr(TRIM(pathname))) .EQ. 1 + +IF (isok) THEN + System_Issock = .TRUE. ELSE - system_issock = .FALSE. + System_Issock = .FALSE. END IF END PROCEDURE System_Issock @@ -50,38 +67,28 @@ ! System_Isfifo !---------------------------------------------------------------------------- -MODULE PROCEDURE system_isfifo +MODULE PROCEDURE System_Isfifo +LOGICAL :: isok -INTERFACE - FUNCTION c_isfifo(pathname) BIND(C, name="my_isfifo") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isfifo -END INTERFACE +isok = C_Isfifo(Str2_Carr(TRIM(pathname))) .EQ. 1 -IF (c_isfifo(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isfifo = .TRUE. +IF (isok) THEN + System_Isfifo = .TRUE. ELSE - system_isfifo = .FALSE. + System_Isfifo = .FALSE. END IF -END PROCEDURE system_isfifo +END PROCEDURE System_Isfifo !---------------------------------------------------------------------------- ! System_Ischr !---------------------------------------------------------------------------- MODULE PROCEDURE System_Ischr -INTERFACE - FUNCTION c_ischr(pathname) BIND(C, name="my_ischr") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_ischr -END INTERFACE - -IF (c_ischr(str2_carr(TRIM(pathname))) .EQ. 1) THEN +LOGICAL :: isok + +isok = C_Ischr(Str2_Carr(TRIM(pathname))) .EQ. 1 +IF (isok) THEN System_Ischr = .TRUE. ELSE System_Ischr = .FALSE. @@ -92,36 +99,26 @@ END FUNCTION c_ischr ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_isreg -INTERFACE - FUNCTION c_isreg(pathname) BIND(C, name="my_isreg") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isreg -END INTERFACE +MODULE PROCEDURE System_Isreg +LOGICAL :: isok -IF (c_isreg(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isreg = .TRUE. +isok = C_Isreg(Str2_Carr(TRIM(pathname))) .EQ. 1 +IF (isok) THEN + System_Isreg = .TRUE. ELSE - system_isreg = .FALSE. + System_Isreg = .FALSE. END IF -END PROCEDURE system_isreg +END PROCEDURE System_Isreg !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- MODULE PROCEDURE System_Islnk -INTERFACE - FUNCTION c_islnk(pathname) BIND(C, name="my_islnk") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_islnk -END INTERFACE - -IF (c_islnk(str2_carr(TRIM(pathname))) .EQ. 1) THEN +LOGICAL :: isok + +isok = C_Islnk(Str2_Carr(TRIM(pathname))) .EQ. 1 +IF (isok) THEN System_Islnk = .TRUE. ELSE System_Islnk = .FALSE. @@ -133,18 +130,13 @@ END FUNCTION c_islnk !---------------------------------------------------------------------------- MODULE PROCEDURE System_Isblk -INTERFACE - FUNCTION c_isblk(pathname) BIND(C, name="my_isblk") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: pathname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isblk -END INTERFACE - -IF (c_isblk(str2_carr(TRIM(pathname))) .EQ. 1) THEN - system_isblk = .TRUE. +LOGICAL :: isok + +isok = C_Isblk(Str2_Carr(TRIM(pathname))) .EQ. 1 +IF (isok) THEN + System_Isblk = .TRUE. ELSE - system_isblk = .FALSE. + System_Isblk = .FALSE. END IF END PROCEDURE System_Isblk @@ -153,15 +145,11 @@ END FUNCTION c_isblk !---------------------------------------------------------------------------- MODULE PROCEDURE System_Isdir -INTERFACE - FUNCTION c_isdir(dirname) BIND(C, name="my_isdir") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: dirname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_isdir -END INTERFACE - -IF (c_isdir(str2_carr(TRIM(dirname))) .EQ. 1) THEN +LOGICAL :: isok + +isok = C_Isdir(Str2_Carr(TRIM(dirname))) .EQ. 1 + +IF (isok) THEN System_Isdir = .TRUE. ELSE System_Isdir = .FALSE. @@ -172,32 +160,4 @@ END FUNCTION c_isdir ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_getcwd -INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG -CHARACTER(kind=C_CHAR, len=1) :: buffer(length) -TYPE(C_PTR) :: buffer2 -INTERFACE - FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) - IMPORT C_CHAR, C_SIZE_T, C_PTR - CHARACTER(kind=C_CHAR), INTENT(out) :: buffer(*) - INTEGER(C_SIZE_T), VALUE, INTENT(in) :: size - TYPE(C_PTR) :: buffer_result - END FUNCTION -END INTERFACE - -buffer = ' ' -buffer2 = c_getcwd(buffer, length) -IF (.NOT. C_ASSOCIATED(buffer2)) THEN - output = '' - ierr = -1 -ELSE - output = TRIM(arr2str(buffer)) - ierr = 0 -END IF -END PROCEDURE system_getcwd - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE EnquiryMethods +END SUBMODULE Methods diff --git a/src/submodules/System/src/System_Method@EnvironmentMethods.F90 b/src/submodules/System/src/SystemEnvironment_Method@Methods.F90 similarity index 56% rename from src/submodules/System/src/System_Method@EnvironmentMethods.F90 rename to src/submodules/System/src/SystemEnvironment_Method@Methods.F90 index 04c2b5e9e..56fac5cf0 100644 --- a/src/submodules/System/src/System_Method@EnvironmentMethods.F90 +++ b/src/submodules/System/src/SystemEnvironment_Method@Methods.F90 @@ -15,8 +15,18 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see ! -SUBMODULE(System_Method) EnvironmentMethods +SUBMODULE(SystemEnvironment_Method) Methods USE ISO_C_BINDING, ONLY: C_SIZE_T +USE ISO_C_BINDING, ONLY: C_INT +USE ISO_C_BINDING, ONLY: C_CHAR +USE ISO_C_BINDING, ONLY: C_NULL_CHAR +USE System_Utility, ONLY: Arr2Str +USE System_Utility, ONLY: Str2_Carr +USE SystemInterface, ONLY: C_Setenv +USE SystemInterface, ONLY: C_Unsetenv +USE SystemInterface, ONLY: C_Readenv +USE SystemInterface, ONLY: C_Putenv +USE SystemInterface, ONLY: System_Initenv IMPLICIT NONE CONTAINS @@ -25,18 +35,11 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_putenv -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_string(*) - END FUNCTION -END INTERFACE - -INTEGER :: loc_err +MODULE PROCEDURE System_Putenv +INTEGER :: Loc_Err INTEGER :: i - -! PUTENV actually adds the data to the environment so the string passed should be saved or will vanish on exit +! PUTENV actually adds the data to the environment so the string passed +! should be saved or will vanish on exit CHARACTER(len=1, kind=C_CHAR), SAVE, POINTER :: memleak(:) ALLOCATE (memleak(LEN(string) + 1)) @@ -45,33 +48,37 @@ INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") END DO memleak(LEN(string) + 1) = C_NULL_CHAR -loc_err = c_putenv(memleak) -IF (PRESENT(err)) err = loc_err -END PROCEDURE system_putenv +Loc_Err = C_Putenv(memleak) +IF (PRESENT(err)) err = Loc_Err +END PROCEDURE System_Putenv !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_getenv +MODULE PROCEDURE System_Getenv INTEGER :: howbig INTEGER :: stat IF (NAME .NE. '') THEN - call get_environment_variable(name, length=howbig, status=stat, trim_name=.true.) ! get length required to hold value + CALL GET_ENVIRONMENT_VARIABLE(name, length=howbig, status=stat, & + Trim_Name=.TRUE.) + ! get length required to hold value IF (howbig .NE. 0) THEN SELECT CASE (stat) CASE (1) ! print *, NAME, " is not defined in the environment. Strange..." VALUE = '' CASE (2) - ! print *, "This processor doesn't support environment variables. Boooh!" + ! print *, "This processor doesn't support environment variables. + ! Boooh!" VALUE = '' - CASE default + CASE DEFAULT ! make string to hold value of sufficient size and get value IF (ALLOCATED(VALUE)) DEALLOCATE (VALUE) ALLOCATE (CHARACTER(len=MAX(howbig, 1)) :: VALUE) - CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, status=stat, trim_name=.TRUE.) + CALL GET_ENVIRONMENT_VARIABLE(name, VALUE, & + status=stat, trim_name=.TRUE.) IF (stat .NE. 0) VALUE = '' END SELECT ELSE @@ -81,33 +88,23 @@ INTEGER(kind=C_INT) FUNCTION c_putenv(c_string) BIND(C, name="putenv") VALUE = '' END IF IF (VALUE .EQ. '' .AND. PRESENT(default)) VALUE = default -END PROCEDURE system_getenv +END PROCEDURE System_Getenv !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE set_environment_variable +MODULE PROCEDURE Set_Environment_Variable INTEGER :: loc_err - -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") - IMPORT C_INT, C_CHAR - CHARACTER(kind=C_CHAR) :: c_name(*) - CHARACTER(kind=C_CHAR) :: c_VALUE(*) - END FUNCTION -END INTERFACE - -loc_err = c_setenv(str2_carr(TRIM(NAME)), str2_carr(VALUE)) -IF (PRESENT(STATUS)) STATUS = loc_err - -END PROCEDURE set_environment_variable +loc_err = C_Setenv(Str2_Carr(TRIM(NAME)), Str2_Carr(VALUE)) +IF (PRESENT(STATUS)) STATUS = Loc_Err +END PROCEDURE Set_Environment_Variable !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_clearenv +MODULE PROCEDURE System_Clearenv ! emulating because not available on some platforms CHARACTER(len=:), ALLOCATABLE :: string INTEGER :: ierr_local1, ierr_local2 @@ -115,68 +112,59 @@ INTEGER(kind=C_INT) FUNCTION c_setenv(c_name, c_VALUE) BIND(C, NAME="setenv") ierr_local2 = 0 INFINITE: DO - CALL system_initenv() + CALL System_Initenv() ! important -- changing table causes undefined behavior ! so reset after each unsetenv - string = system_readenv() + string = System_Readenv() ! get first name=value pair IF (string .EQ. '') EXIT INFINITE - CALL system_unsetenv(string(1:INDEX(string, '=') - 1), ierr_local1) ! remove first name=value pair - IF (ierr_local1 .NE. 0) ierr_local2 = ierr_local1 + CALL System_Unsetenv(string(1:INDEX(string, '=') - 1), Ierr_Local1) + ! remove first name=value pair + IF (Ierr_Local1 .NE. 0) Ierr_Local2 = Ierr_Local1 END DO INFINITE IF (PRESENT(ierr)) THEN - ierr = ierr_local2 -ELSEIF (ierr_local2 .NE. 0) THEN -! if error occurs and not being returned, stop - WRITE (*, *) '*system_clearenv* error=', ierr_local2 + ierr = Ierr_Local2 +ELSEIF (Ierr_Local2 .NE. 0) THEN + ! if error occurs and not being returned, stop + WRITE (*, *) '*System_Clearenv* error=', Ierr_Local2 STOP END IF -END PROCEDURE system_clearenv +END PROCEDURE System_Clearenv !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_unsetenv +MODULE PROCEDURE System_Unsetenv INTEGER :: ierr_local -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_unsetenv(c_name) BIND(C, NAME="unsetenv") - IMPORT C_INT, C_CHAR - CHARACTER(len=1, kind=C_CHAR) :: c_name(*) - END FUNCTION -END INTERFACE - -ierr_local = c_unsetenv(str2_carr(TRIM(NAME))) +ierr_local = C_Unsetenv(Str2_Carr(TRIM(NAME))) IF (PRESENT(ierr)) THEN - ierr = ierr_local -ELSEIF (ierr_local .NE. 0) THEN ! if error occurs and not being returned, stop - WRITE (*, *) '*system_unsetenv* error=', ierr_local + ierr = Ierr_Local +ELSEIF (Ierr_Local .NE. 0) THEN + ! if error occurs and not being returned, stop + WRITE (*, *) '*System_Unsetenv* error=', Ierr_Local STOP END IF - -END PROCEDURE system_unsetenv +END PROCEDURE System_Unsetenv !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_readenv -CHARACTER(kind=C_CHAR) :: c_buff(longest_env_variable + 1) +MODULE PROCEDURE System_Readenv +CHARACTER(kind=C_CHAR) :: C_Buff(LONGEST_ENV_VARIABLE + 1) -INTERFACE - SUBROUTINE c_readenv(c_string) BIND(C, NAME='my_readenv') - IMPORT C_CHAR, C_INT, C_PTR, C_SIZE_T - CHARACTER(kind=C_CHAR), INTENT(out) :: c_string(*) - END SUBROUTINE c_readenv -END INTERFACE +C_Buff = ' ' +C_Buff(Longest_env_Variable + 1:Longest_env_Variable + 1) = C_NULL_CHAR +CALL C_Readenv(C_Buff) +string = TRIM(arr2str(C_Buff)) +END PROCEDURE System_Readenv -c_buff = ' ' -c_buff(longest_env_variable + 1:longest_env_variable + 1) = C_NULL_CHAR -CALL c_readenv(c_buff) -string = TRIM(arr2str(c_buff)) -END PROCEDURE system_readenv +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- -END SUBMODULE EnvironmentMethods +END SUBMODULE Methods diff --git a/src/submodules/System/src/System_Method@FileMethods.F90 b/src/submodules/System/src/SystemFile_Method@Methods.F90 similarity index 79% rename from src/submodules/System/src/System_Method@FileMethods.F90 rename to src/submodules/System/src/SystemFile_Method@Methods.F90 index 2aaac85ac..5e13cd7f4 100644 --- a/src/submodules/System/src/System_Method@FileMethods.F90 +++ b/src/submodules/System/src/SystemFile_Method@Methods.F90 @@ -16,8 +16,30 @@ ! along with this program. If not, see ! -SUBMODULE(System_Method) FileMethods +SUBMODULE(SystemFile_Method) Methods USE ISO_C_BINDING, ONLY: C_ASSOCIATED +USE ISO_C_BINDING, ONLY: C_SIZE_T +USE ISO_C_BINDING, ONLY: C_LONG +USE ISO_C_BINDING, ONLY: C_CHAR +USE System_Utility, ONLY: Matchw +USE System_Utility, ONLY: Arr2Str +USE System_Utility, ONLY: C2F_String +USE System_Utility, ONLY: Str2_Carr +USE System_Utility, ONLY: TimeStamp + +USE SystemInterface, ONLY: C_Utime +USE SystemInterface, ONLY: C_RealPath +USE SystemInterface, ONLY: C_Chown +USE SystemInterface, ONLY: C_Link +USE SystemInterface, ONLY: C_Unlink +USE SystemInterface, ONLY: C_Chdir +USE SystemInterface, ONLY: C_Remove +USE SystemInterface, ONLY: C_Rename +USE SystemInterface, ONLY: C_Chmod +USE SystemInterface, ONLY: System_Getpid +USE SystemInterface, ONLY: System_Errno +USE SystemInterface, ONLY: System_Umask + IMPLICIT NONE CONTAINS @@ -37,7 +59,9 @@ times_local = timestamp() END IF -isok = c_utime(str2_carr(TRIM(pathname)), INT(times_local, kind=C_INT)) .EQ. 0 +isok = C_Utime(Str2_Carr(TRIM(pathname)), INT(Times_Local, kind=C_INT)) & + .EQ. 0 + IF (isok) THEN system_utime = .TRUE. ELSE @@ -66,18 +90,8 @@ MODULE PROCEDURE System_Chown LOGICAL :: isok -INTERFACE - function c_chown(c_dirname,c_owner,c_group) bind (C,name="my_chown") result (c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_dirname(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_owner - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_group - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_chown -END INTERFACE - -isok = c_chown( & - str2_carr(TRIM(dirname)), & +isok = C_Chown( & + Str2_Carr(TRIM(dirname)), & INT(owner, kind=C_INT), & INT(group, kind=C_INT)) .EQ. 1 @@ -90,74 +104,96 @@ END FUNCTION c_chown END PROCEDURE System_Chown !---------------------------------------------------------------------------- -! System_Chdir +! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_chdir -INTERFACE - INTEGER(kind=C_INT) FUNCTION c_chdir(c_path) BIND(C, name="chdir") - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR) :: c_path(*) - END FUNCTION -END INTERFACE +MODULE PROCEDURE system_link +INTEGER(C_INT) :: c_ierr +C_Ierr = C_Link(Str2_Carr(TRIM(oldname)), Str2_Carr(TRIM(newname))) +ierr = c_ierr +END PROCEDURE system_link -INTEGER :: loc_err +!---------------------------------------------------------------------------- +! System_Unlink +!---------------------------------------------------------------------------- -loc_err = c_chdir(str2_carr(TRIM(path))) +MODULE PROCEDURE System_Unlink +ierr = C_Unlink(Str2_Carr(TRIM(fname))) +END PROCEDURE System_Unlink + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Setumask +INTEGER(C_INT) :: Umask_C +Umask_C = Umask_Value +Old_Umask = System_Umask(Umask_C) +END PROCEDURE System_Setumask + +!---------------------------------------------------------------------------- +! System_Chdir +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Chdir +INTEGER :: Loc_Err +Loc_Err = C_Chdir(Str2_Carr(TRIM(path))) IF (PRESENT(err)) THEN - err = loc_err + err = Loc_Err END IF -END PROCEDURE system_chdir +END PROCEDURE System_Chdir !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_remove -INTERFACE - FUNCTION c_remove(c_path) BIND(c, name="remove") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_path(*) - INTEGER(C_INT) :: c_err - END FUNCTION -END INTERFACE - -err = c_remove(str2_carr(TRIM(path))) -END PROCEDURE system_remove +MODULE PROCEDURE System_Remove +err = C_Remove(Str2_Carr(TRIM(path))) +END PROCEDURE System_Remove !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE system_rename -INTERFACE - FUNCTION c_rename(c_input, c_output) BIND(c, name="rename") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_input(*) - CHARACTER(kind=C_CHAR), INTENT(in) :: c_output(*) - INTEGER(C_INT) :: c_err - END FUNCTION -END INTERFACE +MODULE PROCEDURE System_Rename +ierr = C_Rename(Str2_Carr(TRIM(input)), Str2_Carr(TRIM(output))) +END PROCEDURE System_Rename -ierr = c_rename(str2_carr(TRIM(input)), str2_carr(TRIM(output))) -END PROCEDURE system_rename +!---------------------------------------------------------------------------- +! System_Chmod +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Chmod +ierr = C_Chmod(Str2_Carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) +END PROCEDURE System_Chmod !---------------------------------------------------------------------------- -! +! System_Getcwd !---------------------------------------------------------------------------- -MODULE PROCEDURE system_chmod +MODULE PROCEDURE system_getcwd +INTEGER(kind=C_LONG), PARAMETER :: length = 4097_C_LONG +CHARACTER(kind=C_CHAR, len=1) :: buffer(length) +TYPE(C_PTR) :: buffer2 INTERFACE - FUNCTION c_chmod(c_filename, c_mode) BIND(c, name="chmod") RESULT(c_err) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR), INTENT(in) :: c_filename(*) - INTEGER(C_INT), VALUE, INTENT(in) :: c_mode - INTEGER(C_INT) :: c_err + FUNCTION c_getcwd(buffer, size) BIND(c, name="getcwd") RESULT(buffer_result) + IMPORT C_CHAR, C_SIZE_T, C_PTR + CHARACTER(kind=C_CHAR), INTENT(out) :: buffer(*) + INTEGER(C_SIZE_T), VALUE, INTENT(in) :: size + TYPE(C_PTR) :: buffer_result END FUNCTION END INTERFACE -ierr = c_chmod(str2_carr(TRIM(filename)), INT(mode, KIND(0_C_INT))) -END PROCEDURE system_chmod +buffer = ' ' +buffer2 = c_getcwd(buffer, length) +IF (.NOT. C_ASSOCIATED(buffer2)) THEN + output = '' + ierr = -1 +ELSE + output = TRIM(arr2str(buffer)) + ierr = 0 +END IF +END PROCEDURE system_getcwd !---------------------------------------------------------------------------- ! @@ -409,53 +445,8 @@ END FUNCTION c_closedir CALL system_closedir(dir, ierr) !--- close directory stream END PROCEDURE system_dir -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_link -INTEGER(kind=C_INT) :: c_ierr - -INTERFACE - FUNCTION c_link(c_oldname, c_newname) BIND(C, name="link") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_oldname(*) - CHARACTER(kind=C_CHAR, len=1), INTENT(in) :: c_newname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_link -END INTERFACE - -c_ierr = c_link(str2_carr(TRIM(oldname)), str2_carr(TRIM(newname))) -ierr = c_ierr -END PROCEDURE system_link - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_unlink -INTERFACE - FUNCTION c_unlink(c_fname) BIND(C, name="unlink") RESULT(c_ierr) - IMPORT C_CHAR, C_INT - CHARACTER(kind=C_CHAR, len=1) :: c_fname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_unlink -END INTERFACE -ierr = c_unlink(str2_carr(TRIM(fname))) -END PROCEDURE system_unlink - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_setumask -INTEGER(kind=C_INT) :: umask_c -umask_c = umask_value -old_umask = system_umask(umask_c) -! set current umask -END PROCEDURE system_setumask - !---------------------------------------------------------------------------- ! Include Error !---------------------------------------------------------------------------- -END SUBMODULE FileMethods + +END SUBMODULE Methods diff --git a/src/submodules/System/src/SystemProcess_Method@Methods.F90 b/src/submodules/System/src/SystemProcess_Method@Methods.F90 new file mode 100644 index 000000000..5736b4be1 --- /dev/null +++ b/src/submodules/System/src/SystemProcess_Method@Methods.F90 @@ -0,0 +1,198 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(SystemProcess_Method) Methods +USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT +USE ISO_C_BINDING, ONLY: C_LONG_LONG +USE ISO_C_BINDING, ONLY: C_SIZE_T +USE ISO_C_BINDING, ONLY: C_ASSOCIATED +USE System_Utility, ONLY: Anyinteger_to_64bit +USE System_Utility, ONLY: Arr2Str +USE System_Utility, ONLY: C2F_String +USE System_Utility, ONLY: Str2_Carr +USE SystemInterface, ONLY: C_CPU_Time +USE SystemInterface, ONLY: System_Umask +USE SystemInterface, ONLY: C_Perror +USE SystemInterface, ONLY: C_Flush +USE SystemInterface, ONLY: C_Uname +USE SystemInterface, ONLY: C_Gethostname +USE SystemInterface, ONLY: C_Getlogin +USE SystemInterface, ONLY: C_Perm +USE SystemInterface, ONLY: C_Getgrgid +USE SystemInterface, ONLY: C_Getpwuid +USE SystemInterface, ONLY: C_Stat +USE SystemInterface, ONLY: System_Geteuid + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! system_cpu_time +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_CPU_Time +REAL(C_FLOAT) :: C_User, C_System, C_Total + +CALL C_CPU_Time(C_Total, C_User, C_System) +user = C_User +system = C_System +total = C_Total +END PROCEDURE System_CPU_Time + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Getumask +INTEGER :: idum +INTEGER(C_INT) :: Old_Umask + +Old_Umask = System_Umask(0_C_INT) +! get current umask but by setting umask to 0 +! (a conservative mask so no vulnerability is open) +idum = System_Umask(Old_Umask) +! set back to original mask +Umask_Value = Old_Umask +END PROCEDURE System_Getumask + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Perror +INTEGER :: ios +FLUSH (unit=ERROR_UNIT, iostat=ios) +FLUSH (unit=OUTPUT_UNIT, iostat=ios) +FLUSH (unit=INPUT_UNIT, iostat=ios) +CALL C_Perror(Str2_Carr((TRIM(prefix)))) +CALL C_Flush() +END PROCEDURE System_Perror + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Uname +NAMEOUT = 'unknown' +CALL C_Uname(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) +END PROCEDURE System_Uname + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Gethostname +CHARACTER(kind=C_CHAR, len=1) :: C_BUFF(HOST_NAME_MAX + 1) +C_BUFF = ' ' +ierr = C_Gethostname(C_BUFF, HOST_NAME_MAX) +! Host names are limited to {HOST_NAME_MAX} bytes. +NAME = TRIM(arr2str(C_BUFF)) +END PROCEDURE System_Gethostname + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Getlogin +TYPE(C_PTR) :: username +username = C_Getlogin() +IF (.NOT. C_ASSOCIATED(username)) THEN + ! In windows 10 subsystem running Ubunto does not work + !write(*,'(a)')'*System_Getlogin* Error getting username. not associated' + !fname=C_null_Char + fname = System_Getpwuid(System_Geteuid()) +ELSE + fname = C2f_String(username) +END IF +END PROCEDURE System_Getlogin + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Perm +TYPE(C_PTR) :: permissions +INTEGER(C_LONG) :: Mode_Local + +Mode_Local = INT(Anyinteger_to_64bit(mode), kind=C_LONG) +permissions = C_Perm(Mode_Local) +IF (.NOT. C_ASSOCIATED(permissions)) THEN + WRITE (*, '(a)') '*System_Perm* Error getting permissions. not associated' + perms = C_NULL_CHAR +ELSE + perms = C2f_String(permissions) +END IF +END PROCEDURE System_Perm + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Getgrgid +CHARACTER(kind=C_CHAR, len=1) :: groupname(4097) +! assumed long enough for any groupname +INTEGER :: ierr +INTEGER(C_LONG_LONG) :: Gid_Local + +Gid_Local = Anyinteger_to_64bit(gid) +ierr = C_Getgrgid(Gid_Local, groupname) +IF (ierr .EQ. 0) THEN + gname = TRIM(arr2str(groupname)) +ELSE + gname = '' +END IF +END PROCEDURE System_Getgrgid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Getpwuid +CHARACTER(kind=C_CHAR, len=1) :: username(4097) +! assumed long enough for any username +INTEGER :: ierr +INTEGER(kind=C_LONG_LONG) :: Uid_Local + +Uid_Local = Anyinteger_to_64bit(uid) +ierr = C_Getpwuid(Uid_Local, username) +IF (ierr .EQ. 0) THEN + uname = TRIM(arr2str(username)) +ELSE + uname = '' +END IF +END PROCEDURE System_Getpwuid + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE System_Stat +INTEGER(kind=C_LONG) :: cvalues(13) +INTEGER(kind=C_INT) :: cierr + +CALL C_Stat(Str2_Carr(TRIM(pathname)), cvalues, cierr, 0_C_INT) +values = cvalues +IF (PRESENT(ierr)) THEN + ierr = cierr +END IF +END PROCEDURE System_Stat + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/System/src/System_Method@SignalMethods.F90 b/src/submodules/System/src/SystemSignal_Method@Methods.F90 similarity index 75% rename from src/submodules/System/src/System_Method@SignalMethods.F90 rename to src/submodules/System/src/SystemSignal_Method@Methods.F90 index c7a6c2773..b91a2931a 100644 --- a/src/submodules/System/src/System_Method@SignalMethods.F90 +++ b/src/submodules/System/src/SystemSignal_Method@Methods.F90 @@ -15,12 +15,26 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -SUBMODULE(System_Method) SignalMethods +SUBMODULE(SystemSignal_Method) Methods USE ISO_C_BINDING, ONLY: C_FUNLOC - +USE SystemInterface, ONLY: C_Signal IMPLICIT NONE + CONTAINS +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE f_handler +LOGICAL :: isok + +isok = ASSOCIATED(handler_ptr_array(signum)%sub) +IF (isok) THEN + CALL handler_ptr_array(signum)%sub(signum) +END IF +END PROCEDURE f_handler + !---------------------------------------------------------------------------- ! System_Signal !---------------------------------------------------------------------------- @@ -38,4 +52,4 @@ ret = C_Signal(signum, c_handler) END PROCEDURE System_Signal -END SUBMODULE SignalMethods +END SUBMODULE Methods diff --git a/src/submodules/System/src/System_Method@GetMethods.F90 b/src/submodules/System/src/System_Method@GetMethods.F90 deleted file mode 100644 index b3723fea4..000000000 --- a/src/submodules/System/src/System_Method@GetMethods.F90 +++ /dev/null @@ -1,260 +0,0 @@ -! This program is a part of EASIFEM library -! Expandable And Scalable Infrastructure for Finite Element Methods -! htttps://www.easifem.com -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -SUBMODULE(System_Method) GetMethods -USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT -USE ISO_C_BINDING, ONLY: C_LONG_LONG -USE ISO_C_BINDING, ONLY: C_SIZE_T -USE ISO_C_BINDING, ONLY: C_ASSOCIATED - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! system_cpu_time -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_cpu_time -REAL(kind=C_FLOAT) :: c_user, c_system, c_total -INTERFACE - SUBROUTINE c_cpu_time(c_total, c_user, c_system) BIND(C, NAME='my_cpu_time') - IMPORT :: C_FLOAT - REAL(kind=C_FLOAT) :: c_total, c_user, c_system - END SUBROUTINE c_cpu_time -END INTERFACE - -CALL c_cpu_time(c_total, c_user, c_system) -user = c_user -system = c_system -total = c_total -END PROCEDURE system_cpu_time - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_getumask -INTEGER :: idum -INTEGER(kind=C_INT) :: old_umask - -old_umask = system_umask(0_C_INT) -! get current umask but by setting umask to 0 -! (a conservative mask so no vulnerability is open) -idum = system_umask(old_umask) -! set back to original mask -umask_value = old_umask -END PROCEDURE system_getumask - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_perror -INTEGER :: ios - -INTERFACE - SUBROUTINE c_perror(c_prefix) BIND(C, name="perror") - IMPORT C_CHAR - CHARACTER(kind=C_CHAR) :: c_prefix(*) - END SUBROUTINE c_perror -END INTERFACE - -FLUSH (unit=ERROR_UNIT, iostat=ios) -FLUSH (unit=OUTPUT_UNIT, iostat=ios) -FLUSH (unit=INPUT_UNIT, iostat=ios) -CALL c_perror(str2_carr((TRIM(prefix)))) -CALL c_flush() -END PROCEDURE system_perror - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_uname -! describe the C routine to Fortran -! void system_uname(char *which, char *buf, int *buflen); -INTERFACE - SUBROUTINE system_uname_c(WHICH, BUF, BUFLEN) BIND(C, NAME='my_uname') - IMPORT C_CHAR, C_INT - IMPLICIT NONE - CHARACTER(KIND=C_CHAR), INTENT(in) :: WHICH - CHARACTER(KIND=C_CHAR), INTENT(out) :: BUF(*) - INTEGER(kind=C_INT), INTENT(in) :: BUFLEN - END SUBROUTINE system_uname_c -END INTERFACE - -NAMEOUT = 'unknown' -CALL system_uname_c(WHICH, NAMEOUT, INT(LEN(NAMEOUT), KIND(0_C_INT))) -END PROCEDURE system_uname - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_gethostname -CHARACTER(kind=C_CHAR, len=1) :: C_BUFF(HOST_NAME_MAX + 1) - -! describe the C routine to Fortran -!int gethostname(char *name, size_t namelen); -INTERFACE - FUNCTION system_gethostname_c(c_buf, c_buflen) BIND(C, NAME='gethostname') - IMPORT C_CHAR, C_INT - IMPLICIT NONE - INTEGER(kind=C_INT) :: system_gethostname_c - CHARACTER(KIND=C_CHAR), INTENT(out) :: c_buf(*) - INTEGER(kind=C_INT), INTENT(in), VALUE :: c_buflen - END FUNCTION system_gethostname_c -END INTERFACE - -C_BUFF = ' ' -ierr = system_gethostname_c(C_BUFF, HOST_NAME_MAX) ! Host names are limited to {HOST_NAME_MAX} bytes. -NAME = TRIM(arr2str(C_BUFF)) -END PROCEDURE system_gethostname - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_getlogin -TYPE(C_PTR) :: username - -INTERFACE - FUNCTION c_getlogin() BIND(c, name="getlogin") RESULT(c_username) - IMPORT C_INT, C_PTR - TYPE(C_PTR) :: c_username - END FUNCTION c_getlogin -END INTERFACE - -username = c_getlogin() -IF (.NOT. C_ASSOCIATED(username)) THEN - ! In windows 10 subsystem running Ubunto does not work - !write(*,'(a)')'*system_getlogin* Error getting username. not associated' - !fname=c_null_char - fname = system_getpwuid(system_geteuid()) -ELSE - fname = c2f_string(username) -END IF -END PROCEDURE system_getlogin - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_perm -TYPE(C_PTR) :: permissions -INTEGER(kind=C_LONG) :: mode_local - -INTERFACE - FUNCTION c_perm(c_mode) BIND(c, name="my_get_perm") RESULT(c_permissions) - IMPORT C_INT, C_PTR, C_LONG - INTEGER(kind=C_LONG), VALUE :: c_mode - TYPE(C_PTR) :: c_permissions - END FUNCTION c_perm -END INTERFACE - -mode_local = INT(anyinteger_to_64bit(mode), kind=C_LONG) -permissions = c_perm(mode_local) -IF (.NOT. C_ASSOCIATED(permissions)) THEN - WRITE (*, '(a)') '*system_perm* Error getting permissions. not associated' - perms = C_NULL_CHAR -ELSE - perms = c2f_string(permissions) -END IF -END PROCEDURE system_perm - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_getgrgid -CHARACTER(kind=C_CHAR, len=1) :: groupname(4097) -! assumed long enough for any groupname -INTEGER :: ierr -INTEGER(kind=C_LONG_LONG) :: gid_local - -INTERFACE - function c_getgrgid(c_gid,c_groupname) bind(c,name="my_getgrgid") result(c_ierr) - IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG - INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_gid - CHARACTER(kind=C_CHAR), INTENT(out) :: c_groupname(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_getgrgid -END INTERFACE - -gid_local = anyinteger_to_64bit(gid) -ierr = c_getgrgid(gid_local, groupname) -IF (ierr .EQ. 0) THEN - gname = TRIM(arr2str(groupname)) -ELSE - gname = '' -END IF -END PROCEDURE system_getgrgid - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_getpwuid -CHARACTER(kind=C_CHAR, len=1) :: username(4097) -! assumed long enough for any username -INTEGER :: ierr -INTEGER(kind=C_LONG_LONG) :: uid_local - -INTERFACE - function c_getpwuid(c_uid,c_username) bind(c,name="my_getpwuid") result(c_ierr) - IMPORT C_INT, C_PTR, C_CHAR, C_LONG_LONG - INTEGER(kind=C_LONG_LONG), VALUE, INTENT(in) :: c_uid - CHARACTER(kind=C_CHAR), INTENT(out) :: c_username(*) - INTEGER(kind=C_INT) :: c_ierr - END FUNCTION c_getpwuid -END INTERFACE - -uid_local = anyinteger_to_64bit(uid) -ierr = c_getpwuid(uid_local, username) -IF (ierr .EQ. 0) THEN - uname = TRIM(arr2str(username)) -ELSE - uname = '' -END IF -END PROCEDURE system_getpwuid - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE system_stat -INTEGER(kind=C_LONG) :: cvalues(13) -INTEGER(kind=C_INT) :: cierr - -INTERFACE - SUBROUTINE c_stat(buffer, cvalues, cierr, cdebug) BIND(c, name="my_stat") - IMPORT C_CHAR, C_SIZE_T, C_PTR, C_INT, C_LONG - CHARACTER(kind=C_CHAR), INTENT(in) :: buffer(*) - INTEGER(kind=C_LONG), INTENT(out) :: cvalues(*) - INTEGER(kind=C_INT) :: cierr - INTEGER(kind=C_INT), INTENT(in) :: cdebug - END SUBROUTINE c_stat -END INTERFACE - -CALL c_stat(str2_carr(TRIM(pathname)), cvalues, cierr, 0_C_INT) -values = cvalues -IF (PRESENT(ierr)) THEN - ierr = cierr -END IF -END PROCEDURE system_stat - -END SUBMODULE GetMethods diff --git a/src/submodules/System/src/System_Method@UtilityMethods.F90 b/src/submodules/System/src/System_Utility@Methods.F90 similarity index 89% rename from src/submodules/System/src/System_Method@UtilityMethods.F90 rename to src/submodules/System/src/System_Utility@Methods.F90 index 1cc494b38..9f7d9645f 100644 --- a/src/submodules/System/src/System_Method@UtilityMethods.F90 +++ b/src/submodules/System/src/System_Utility@Methods.F90 @@ -15,8 +15,12 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -SUBMODULE(System_Method) UtilityMethods +SUBMODULE(System_Utility) Methods USE ISO_FORTRAN_ENV, ONLY: ERROR_UNIT +USE ISO_C_BINDING, ONLY: C_NULL_CHAR +USE ISO_C_BINDING, ONLY: C_F_POINTER +USE SystemInterface, ONLY: C_Time +USE GlobalData, ONLY: INT8, INT16, INT32 IMPLICIT NONE CONTAINS @@ -25,11 +29,11 @@ ! C2F_String !---------------------------------------------------------------------------- -MODULE PROCEDURE C2F_string -CHARACTER(kind=C_CHAR), DIMENSION(:), POINTER :: & - char_array_pointer => NULL() +MODULE PROCEDURE C2F_String +CHARACTER(kind=C_CHAR), POINTER :: & + char_array_pointer(:) => NULL() INTEGER, PARAMETER :: max_len = 4096 -CHARACTER(len=max_len) :: aux_string +CHARACTER(max_len) :: aux_string INTEGER :: i INTEGER :: length @@ -47,7 +51,8 @@ DO i = 1, max_len IF (char_array_pointer(i) == C_NULL_CHAR) THEN - length = i - 1; EXIT + length = i - 1 + EXIT END IF aux_string(i:i) = char_array_pointer(i) END DO @@ -205,35 +210,26 @@ MODULE PROCEDURE Anyinteger_to_64bit SELECT TYPE (intin) -TYPE IS (INTEGER(kind=INT8)) +TYPE IS (INTEGER(INT8)) ii38 = INT(intin, kind=INT64) -TYPE IS (INTEGER(kind=INT16)) + +TYPE IS (INTEGER(INT16)) ii38 = INT(intin, kind=INT64) -TYPE IS (INTEGER(kind=INT32)) - ii38 = intin -TYPE IS (INTEGER(kind=INT64)) + +TYPE IS (INTEGER(INT32)) + ii38 = INT(intin, kind=INT64) + +TYPE IS (INTEGER(INT64)) ii38 = intin + !class default !write(error_unit,*)'ERROR: unknown integer type' !stop 'ERROR: *Anyinteger_to_64* unknown integer type' END SELECT END PROCEDURE Anyinteger_to_64bit -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE f_handler -LOGICAL :: isok - -isok = ASSOCIATED(handler_ptr_array(signum)%sub) -IF (isok) THEN - CALL handler_ptr_array(signum)%sub(signum) -END IF -END PROCEDURE f_handler - !---------------------------------------------------------------------------- ! Include Error !---------------------------------------------------------------------------- -END SUBMODULE UtilityMethods +END SUBMODULE Methods