diff --git a/doc/specs/index.md b/doc/specs/index.md index c65447045..76734f52c 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -38,6 +38,7 @@ This is an index/directory of the specifications (specs) for each new module/fea - [string\_type](./stdlib_string_type.html) - Basic string support - [stringlist_type](./stdlib_stringlist_type.html) - 1-Dimensional list of strings - [strings](./stdlib_strings.html) - String handling and manipulation routines + - [system](./stdlib_system.html) - OS and sub-processing routines - [version](./stdlib_version.html) - Version information ## Released/Stable Features & Modules diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 8c868802a..87bc0e495 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -260,3 +260,161 @@ Provides formats for all kinds as defined in the `stdlib_kinds` module. ```fortran {!example/io/example_fmt_constants.f90!} ``` + +## `getfile` - Read a whole ASCII file into a string variable + +### Status + +Experimental + +### Description + +This function reads the entirety of a specified ASCII file and returns its content as a string. The function provides an optional error-handling mechanism via the `state_type` class. If the `err` argument is not provided, exceptions will trigger an `error stop`. The function also supports an optional flag to delete the file after reading. + +### Syntax + +`call [[stdlib_io(module):getfile(function)]] (fileName [, err] [, delete=.false.])` + +### Class +Function + +### Arguments + +`fileName`: Shall be a character input containing the path to the ASCII file to read. It is an `intent(in)` argument. + +`err` (optional): Shall be a `type(state_type)` variable. It is an `intent(out)` argument used for error handling. + +`delete` (optional): Shall be a `logical` flag. If `.true.`, the file is deleted after reading. Default is `.false.`. It is an `intent(in)` argument. + +### Return values + +The function returns a `string_type` variable containing the full content of the specified file. + +Raises `STDLIB_IO_ERROR` if the file is not found, cannot be opened, read, or deleted. +Exceptions trigger an `error stop` unless the optional `err` argument is provided. + +### Example + +```fortran +program example_getfile + use stdlib_io + implicit none + + type(string_type) :: fileContent + type(state_type) :: err + + ! Read a file into a string + fileContent = getfile("example.txt", err=err) + + if (err%error()) then + print *, "Error reading file:", err%print() + else + print *, "File content:", fileContent + end if +end program example_getfile +``` + +## `is_directory` - Test if a path is a directory + +### Status + +Experimental + +### Description + +This function checks if a specified file system path is a directory. It is designed to work across multiple platforms without relying on external C libraries, using system commands native to the detected operating system. + +Supported operating systems include Linux, macOS, Windows, and UNIX-like environments (e.g., FreeBSD, OpenBSD). If the operating system is unknown or unsupported, the function will return `.false.`. + +### Syntax + +`result = [[stdlib_io(module):is_directory(function)]] (path)` + +### Class +Function + +### Arguments + +`path`: Shall be a character string containing the file system path to evaluate. It is an `intent(in)` argument. + +### Return values + +The function returns a `logical` value: + +- `.true.` if the path matches an existing directory. +- `.false.` otherwise, or if the operating system is unsupported. + +### Example + +```fortran +program example_is_directory + use stdlib_io + implicit none + + logical :: isDir + + ! Test a directory path + isDir = is_directory("/path/to/check") + + if (isDir) then + print *, "The specified path is a directory." + else + print *, "The specified path is not a directory." + end if +end program example_is_directory +``` + +## `delete_file` - Delete a file + +### Status + +Experimental + +### Description + +This subroutine deletes a specified file from the filesystem. It ensures that the file exists and is not a directory before attempting deletion. +If the file cannot be deleted due to permissions, being a directory, or other issues, an error is raised. +Errors are handled using the library's `state_type`. If the optional `err` argument is not provided, exceptions trigger an `error stop`. + +### Syntax + +`call [[stdlib_fs(module):delete_file(subroutine)]] (path [, err])` + +### Class +Subroutine + +### Arguments + +`path`: Shall be a character string containing the path to the file to be deleted. It is an `intent(in)` argument. + +`err` (optional): Shall be a `type(state_type)` variable for error handling. If provided, errors are returned as a state object. If not provided, the program stops execution on error. + +### Behavior + +- Checks if the file exists. If not, an error is raised. +- Ensures the path is not a directory before deletion. +- Attempts to delete the file, raising an error if unsuccessful. + +### Return values + +The file is removed from the filesystem if the operation is successful. If the operation fails, an error is raised. + +### Example + +```fortran +program example_delete_file + use stdlib_fs + implicit none + + type(state_type) :: err + + ! Delete a file with error handling + call delete_file("example.txt", err) + + if (err%error()) then + print *, "Failed to delete file:", err%print() + else + print *, "File deleted successfully." + end if +end program example_delete_file +``` diff --git a/doc/specs/stdlib_system.md b/doc/specs/stdlib_system.md new file mode 100644 index 000000000..adbc2c647 --- /dev/null +++ b/doc/specs/stdlib_system.md @@ -0,0 +1,219 @@ +--- +title: system +--- + +# System and sub-processing module + +[TOC] + +## `run` - Execute a synchronous command + +### Status + +Experimental + +### Description + +This subroutine executes a command in the system shell synchronously, waiting for its completion before returning. It provides the option to capture the command's standard output (`stdout`) and standard error (`stderr`), along with its exit and command states. + +The implementation relies on Fortran's `execute_command_line`. + +### Syntax + +`call [[stdlib_system(module):run(subroutine)]](cmd [, exit_state] [, command_state] [, stdout] [, stderr])` + +### Class + +Subroutine + +### Arguments + +`cmd`: Shall be a scalar `character(len=*)` input argument containing the shell command to execute. + +`exit_state` (optional): Shall be an integer `intent(out)` argument, returning the command's exit state (usually `0` on success). + +`command_state` (optional): Shall be an integer `intent(out)` argument, indicating issues with command invocation. + +`stdout` (optional): Shall be an `intent(out)` `type(string_type)` variable, capturing the command's standard output. + +`stderr` (optional): Shall be an `intent(out)` `type(string_type)` variable, capturing the command's standard error messages. + +### Return Values + +- Captures the exit state and command state of the executed command. +- Retrieves `stdout` and/or `stderr` if the respective optional arguments are provided. +- Raises an error via `error stop` if no `exit_state` or `command_state` arguments are provided and an issue occurs. + +### Example + +```fortran +program example_run + use stdlib_system, only: run + implicit none + type(string_type) :: output, error_output + integer :: exit_status, cmd_status + + call run("ls -l", exit_state=exit_status, command_state=cmd_status, stdout=output, stderr=error_output) + + if (exit_status == 0) then + print *, "Command executed successfully!" + print *, "Output:", trim(output) + else + print *, "Error occurred:", trim(error_output) + end if +end program example_run +``` + +## `null_device` - Return the null device file path + +### Status + +Experimental + +### Description + +This function returns the file path of the null device, which is a special file used to discard any data written to it. +It reads as an empty file. The null device's path varies by operating system: +- On Windows, the null device is represented as `NUL`. +- On UNIX-like systems (Linux, macOS), the null device is represented as `/dev/null`. + +### Syntax + +`path = [[stdlib_system(module):null_device(function)]]()` + +### Class + +Function + +### Arguments + +None. + +### Return Value + +- **Type:** `character(:), allocatable` +- Returns the null device file path as a character string, appropriate for the operating system. + +### Example + +```fortran +program example_null_device + use stdlib_system, only: null_device + implicit none + character(:), allocatable :: null_path + + ! Retrieve the null device path + null_path = null_device() + + print *, "The null device path is: ", null_path +end program example_null_device +``` + +## `runtime_os` - Determine the OS type at runtime + +### Status + +Experimental + +### Description + +`runtime_os` inspects the runtime environment to identify the current OS type. It evaluates environment variables (`OSTYPE`, `OS`) and checks for specific files associated with known operating systems. +The supported OS types are: + +- **Linux** (`OS_LINUX`) +- **macOS** (`OS_MACOS`) +- **Windows** (`OS_WINDOWS`) +- **Cygwin** (`OS_CYGWIN`) +- **Solaris** (`OS_SOLARIS`) +- **FreeBSD** (`OS_FREEBSD`) +- **OpenBSD** (`OS_OPENBSD`) + +If the OS cannot be identified, the function returns `OS_UNKNOWN`. + +### Syntax + +`os = [[stdlib_system(module):runtime_os(function)]]()` + +### Class + +Function + +### Arguments + +None. + +### Return Value + +- **Type:** `integer` +- Returns a constant representing the OS type, or `OS_UNKNOWN` if undetermined. + +### Example + +```fortran +program example_os_detection + use stdlib_system, only: OS_TYPE, runtime_os + implicit none + integer :: os_type_cached, os_type_runtime + + ! Cached OS detection + os_type_cached = OS_TYPE() + print *, "Cached OS Type: ", os_type_cached + + ! Runtime OS detection (full inspection) + os_type_runtime = runtime_os() + print *, "Runtime OS Type: ", os_type_runtime +end program example_os_detection +``` + +--- + +## `OS_TYPE` - Cached OS type retrieval + +### Status + +Experimental + +### Description + +`OS_TYPE` provides a cached result of the `runtime_os` function. The OS type is determined during the first invocation and stored in a static variable. +Subsequent calls reuse the cached value, making this function highly efficient. + +This caching mechanism ensures negligible overhead for repeated calls, unlike `runtime_os`, which performs a full runtime inspection. + +### Syntax + +`os = [[stdlib_system(module):OS_TYPE(function)]]()` + +### Class + +Function + +### Arguments + +None. + +### Return Value + +- **Type:** `integer` +- Returns a cached constant representing the OS type, as determined by `runtime_os`. + +--- + +### Example + +```fortran +program example_os_detection + use stdlib_system, only: OS_TYPE, runtime_os + implicit none + integer :: os_type_cached, os_type_runtime + + ! Cached OS detection + os_type_cached = OS_TYPE() + print *, "Cached OS Type: ", os_type_cached + + ! Runtime OS detection (full inspection) + os_type_runtime = runtime_os() + print *, "Runtime OS Type: ", os_type_runtime +end program example_os_detection +``` + diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a43ed3001..15c99057a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -107,6 +107,7 @@ set(SRC stdlib_hashmaps.f90 stdlib_hashmap_chaining.f90 stdlib_hashmap_open.f90 + stdlib_io_filesystem.F90 stdlib_logger.f90 stdlib_sorting_radix_sort.f90 stdlib_system.F90 diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index 01b50a881..3b57019b4 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -9,14 +9,34 @@ module stdlib_io use, intrinsic :: iso_fortran_env, only : input_unit use stdlib_kinds, only: sp, dp, xdp, qp, & int8, int16, int32, int64 - use stdlib_error, only: error_stop + use stdlib_error, only: error_stop, state_type, STDLIB_IO_ERROR use stdlib_optval, only: optval use stdlib_ascii, only: is_blank - use stdlib_string_type, only : string_type + use stdlib_string_type implicit none private ! Public API public :: loadtxt, savetxt, open, getline + + !! version: experimental + !! + !! Reads a whole ASCII file and loads its contents into a string variable. + !! ([Specification](../page/specs/stdlib_io.html#getfile-read-a-whole-ascii-file-into-a-string-variable)) + !! + !!### Summary + !! Function interface for reading the content of a file into a string. + !! + !!### Description + !! + !! This function reads the entirety of a specified ASCII file and returns it as a string. The optional + !! `err` argument allows for handling errors through the library's `state_type` class. + !! An optional `logical` flag can be passed to delete the file after reading. + !! + !!@note Handles errors using the library's `state_type` error-handling class. If not provided, + !! exceptions will trigger an `error stop`. + !! + public :: getfile + ! Private API that is exposed so that we can test it in tests public :: parse_mode @@ -528,4 +548,96 @@ contains call getline(input_unit, line, iostat, iomsg) end subroutine getline_input_string + !> Version: experimental + !> + !> Reads a whole ASCII file and loads its contents into a string variable. + !> The function handles error states and optionally deletes the file after reading. + type(string_type) function getfile(fileName,err,delete) result(file) + !> Input file name + character(*), intent(in) :: fileName + !> [optional] State return flag. On error, if not requested, the code will stop. + type(state_type), optional, intent(out) :: err + !> [optional] Delete file after reading? Default: do not delete + logical, optional, intent(in) :: delete + + ! Local variables + type(state_type) :: err0 + character(len=:), allocatable :: fileString + character(len=512) :: iomsg + integer :: lun,iostat + integer(int64) :: errpos,fileSize + logical :: is_present,want_deleted + + ! Initializations + file = "" + + !> Check if the file should be deleted after reading + if (present(delete)) then + want_deleted = delete + else + want_deleted = .false. + end if + + !> Check file existing + inquire(file=fileName, exist=is_present) + if (.not.is_present) then + err0 = state_type('getfile',STDLIB_IO_ERROR,'File not present:',fileName) + call err0%handle(err) + return + end if + + !> Retrieve file size + inquire(file=fileName,size=fileSize) + + invalid_size: if (fileSize<0) then + + err0 = state_type('getfile',STDLIB_IO_ERROR,fileName,'has invalid size=',fileSize) + call err0%handle(err) + return + + endif invalid_size + + ! Read file + open(newunit=lun,file=fileName, & + form='unformatted',action='read',access='stream',status='old', & + iostat=iostat,iomsg=iomsg) + + if (iostat/=0) then + err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot open',fileName,'for read:',iomsg) + call err0%handle(err) + return + end if + + allocate(character(len=fileSize) :: fileString) + + read_data: if (fileSize>0) then + + read(lun, pos=1, iostat=iostat, iomsg=iomsg) fileString + + ! Read error + if (iostat/=0) then + + inquire(unit=lun,pos=errpos) + err0 = state_type('getfile',STDLIB_IO_ERROR,iomsg,'(',fileName,'at byte',errpos,')') + call err0%handle(err) + return + + endif + + end if read_data + + if (want_deleted) then + close(lun,iostat=iostat,status='delete') + if (iostat/=0) err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot delete',fileName,'after reading') + else + close(lun,iostat=iostat) + if (iostat/=0) err0 = state_type('getfile',STDLIB_IO_ERROR,'Cannot close',fileName,'after reading') + endif + + ! Process output + call move(from=fileString,to=file) + call err0%handle(err) + + end function getfile + end module stdlib_io diff --git a/src/stdlib_io_filesystem.F90 b/src/stdlib_io_filesystem.F90 new file mode 100644 index 000000000..08d1a0918 --- /dev/null +++ b/src/stdlib_io_filesystem.F90 @@ -0,0 +1,169 @@ +! SPDX-Identifier: MIT + +!> Interaction with the filesystem. +module stdlib_io_filesystem + use stdlib_string_type, only: string_type,write(formatted) + use stdlib_error, only: state_type, STDLIB_FS_ERROR + use stdlib_system, only: run, OS_TYPE, OS_UNKNOWN, OS_MACOS, OS_LINUX, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD, OS_WINDOWS + use iso_c_binding, only: c_char, c_int, c_null_char + implicit none + private + + !! version: experimental + !! + !! Deletes a specified file from the filesystem. + !! ([Specification](../page/specs/stdlib_io.html#delete_file-delete-a-file)) + !! + !!### Summary + !! Subroutine to safely delete a file from the filesystem. It handles errors gracefully using the library's `state_type`. + !! + !!### Description + !! + !! This subroutine deletes a specified file. If the file does not exist, or if it is a directory or inaccessible, + !! an error is raised. Errors are handled using the library's `state_type` mechanism. If the optional `err` argument + !! is not provided, exceptions trigger an `error stop`. + !! + public :: delete_file + + !! version: experimental + !! + !! Tests if a given path matches an existing directory. + !! ([Specification](../page/specs/stdlib_io.html#is_directory-test-if-a-path-is-a-directory)) + !! + !!### Summary + !! Function to evaluate whether a specified path corresponds to an existing directory. + !! + !!### Description + !! + !! This function checks if a given file system path is a directory. It is cross-platform and avoids reliance + !! on external C libraries by utilizing system calls. It supports common operating systems such as Linux, macOS, + !! Windows, and various UNIX-like environments. On unsupported operating systems, the function will return `.false.`. + !! + public :: is_directory + +contains + + !! Tests if a given path matches an existing directory. + !! Cross-platform implementation without using external C libraries. + logical function is_directory(path) + !> Input path to evaluate + character(*), intent(in) :: path + + integer :: stat,cstat + type(string_type) :: stdout,stderr + +#ifdef _WIN32 + ! Windows API interface + integer(c_int) :: attrs + integer(c_int), parameter :: FILE_ATTRIBUTE_DIRECTORY = int(z'10',c_int) + + interface + ! Declare the GetFileAttributesA function from kernel32.dll + integer(c_int) function GetFileAttributesA(lpFileName) bind(c, name="GetFileAttributesA") + import c_int, c_char + character(kind=c_char), dimension(*), intent(in) :: lpFileName + end function GetFileAttributesA + end interface +#endif + + select case (OS_TYPE()) + + case (OS_UNKNOWN, OS_LINUX, OS_MACOS, OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD) + + call run("test -d " // trim(path), exit_state=stat, command_state=cstat, stdout=stdout,stderr=stderr) + + case (OS_WINDOWS) + +#ifdef _WIN32 + ! Use Windows API if available + attrs = GetFileAttributesA(c_path(windows_path(path))) + stat = merge(0,-1, attrs /= -1 & ! attributes received + .and. btest(attrs,FILE_ATTRIBUTE_DIRECTORY) ! is directory +#else + ! Fallback to cmd.exe otherwise + call run('cmd /c "if not exist ' // windows_path(path) // '\* exit /B 1"', exit_state=stat) +#endif + + case default + + ! Unknown/invalid OS + stat = -1 + + end select + + is_directory = stat == 0 + + end function is_directory + + subroutine delete_file(path, err) + character(*), intent(in) :: path + type(state_type), optional, intent(out) :: err + + !> Local variables + integer :: file_unit, ios + type(state_type) :: err0 + character(len=512) :: msg + logical :: file_exists + + ! Check if the path exists + inquire(file=path, exist=file_exists) + if (.not. file_exists) then + ! File does not exist, return error status + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,': file does not exist') + call err0%handle(err) + return + endif + + ! Verify the file is not a directory + if (is_directory(path)) then + ! If unable to open, assume it's a directory or inaccessible + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'- is a directory') + call err0%handle(err) + return + end if + + ! Close and delete the file + open(newunit=file_unit, file=path, status='old', iostat=ios, iomsg=msg) + if (ios /= 0) then + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg) + call err0%handle(err) + return + end if + close(unit=file_unit, status='delete', iostat=ios, iomsg=msg) + if (ios /= 0) then + err0 = state_type(STDLIB_FS_ERROR,'Cannot delete',path,'-',msg) + call err0%handle(err) + return + end if + end subroutine delete_file + + !> Replace file system separators for windows + function windows_path(path) result(winpath) + + character(*), intent(in) :: path + character(len_trim(path)) :: winpath + + integer :: idx + + winpath = trim(path) + idx = index(winpath,'/') + do while(idx > 0) + winpath(idx:idx) = '\' + idx = index(winpath,'/') + end do + + end function windows_path + + !> Get a C path + function c_path(path) + character(*), intent(in) :: path + character(c_char) :: c_path(len(path)+1) + + integer :: i + + forall(i=1:len(path)) c_path(i) = path(i:i) + c_path(len(path)+1) = c_null_char + + end function c_path + +end module stdlib_io_filesystem diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 7bcc78baf..b5c9de88f 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -1,9 +1,116 @@ module stdlib_system use, intrinsic :: iso_c_binding, only : c_int, c_long +use stdlib_string_type, only: string_type, assignment(=) +use stdlib_io, only: getfile +use stdlib_error, only: error_stop, state_type implicit none private public :: sleep +!! version: experimental +!! +!! Executes a synchronous command in the system shell and optionally retrieves output and error messages. +!! ([Specification](../page/specs/stdlib_system.html#run-execute-a-synchronous-command)) +!! +!! ### Summary +!! Subroutine interface for running a shell command synchronously, capturing its exit and command states, +!! and optionally retrieving the command's `stdout` and `stderr`. +!! +!! ### Description +!! +!! This interface enables executing a system command with the option to retrieve outputs. The execution +!! is synchronous, meaning the calling program waits until the command completes before proceeding. +!! The command's status codes, `stdout`, and `stderr` outputs can be retrieved through optional arguments. +!! +!! @note Implementation is based on Fortran's `execute_command_line`. +!! +public :: run + +!! version: experimental +!! +!! Returns the file path of the null device, which discards all data written to it. +!! ([Specification](../page/specs/stdlib_system.html#null_device-return-the-null-device-file-path)) +!! +!! ### Summary +!! Function that provides the appropriate null device file path for the current operating system. +!! +!! ### Description +!! +!! The null device is a special file that discards all data written to it and always reads as +!! an empty file. This function returns the null device path, adapted for the operating system in use. +!! +!! On Windows, this is `NUL`. On UNIX-like systems, this is `/dev/null`. +!! +public :: null_device + +!! version: experimental +!! +!! Cached OS type retrieval with negligible runtime overhead. +!! ([Specification](../page/specs/stdlib_system.html#os_type-cached-os-type-retrieval)) +!! +!! ### Summary +!! Provides a cached value for the runtime OS type. +!! +!! ### Description +!! +!! This function caches the result of `runtime_os` after the first invocation. +!! Subsequent calls return the cached value, ensuring minimal overhead. +!! +public :: OS_TYPE + +!! version: experimental +!! +!! Determine the current operating system (OS) type at runtime. +!! ([Specification](../page/specs/stdlib_system.html#runtime_os-determine-the-os-type-at-runtime)) +!! +!! ### Summary +!! This function inspects the runtime environment to identify the OS type. +!! +!! ### Description +!! +!! The function evaluates environment variables (`OSTYPE` or `OS`) and filesystem attributes +!! to identify the OS. It distinguishes between several common operating systems: +!! - Linux +!! - macOS +!! - Windows +!! - Cygwin +!! - Solaris +!! - FreeBSD +!! - OpenBSD +!! +!! Returns a constant representing the OS type or `OS_UNKNOWN` if the OS cannot be determined. +!! +public :: runtime_os + +!> Version: experimental +!> +!> Integer constants representing known operating system (OS) types +!> ([Specification](../page/specs/stdlib_system.html)) +integer, parameter, public :: & + !> Represents an unknown operating system + OS_UNKNOWN = 0, & + !> Represents a Linux operating system + OS_LINUX = 1, & + !> Represents a macOS operating system + OS_MACOS = 2, & + !> Represents a Windows operating system + OS_WINDOWS = 3, & + !> Represents a Cygwin environment + OS_CYGWIN = 4, & + !> Represents a Solaris operating system + OS_SOLARIS = 5, & + !> Represents a FreeBSD operating system + OS_FREEBSD = 6, & + !> Represents an OpenBSD operating system + OS_OPENBSD = 7 + +!! Helper function returning the name of an OS parameter +public :: OS_NAME + +!! Static storage for the current OS +logical :: have_os = .false. +integer :: OS_CURRENT = OS_UNKNOWN + interface #ifdef _WIN32 subroutine winsleep(dwMilliseconds) bind (C, name='Sleep') @@ -40,10 +147,209 @@ subroutine sleep(millisec) #else !! Linux, Unix, MacOS, MSYS2, ... ierr = usleep(int(millisec * 1000, c_int)) -if (ierr/=0) error stop 'problem with usleep() system call' +if (ierr/=0) call error_stop('problem with usleep() system call') #endif end subroutine sleep +!> Retrieves the cached OS type for minimal runtime overhead. +integer function OS_TYPE() result(os) + !! This function uses a static cache to avoid recalculating the OS type after the first call. + !! It is recommended for performance-sensitive use cases where the OS type is checked multiple times. + if (.not.have_os) then + OS_CURRENT = runtime_os() + have_os = .true. + end if + os = OS_CURRENT +end function OS_TYPE + +!> Returns the file path of the null device for the current operating system. +function null_device() result(path) + !> File path of the null device + character(:), allocatable :: path + if (OS_TYPE()==OS_WINDOWS) then + path = 'NUL' + else + path = '/dev/null' + end if +end function null_device + +integer function runtime_os() result(os) + !! The function identifies the OS by inspecting environment variables and filesystem attributes. + !! + !! ### Returns: + !! - **OS_UNKNOWN**: If the OS cannot be determined. + !! - **OS_LINUX**, **OS_MACOS**, **OS_WINDOWS**, **OS_CYGWIN**, **OS_SOLARIS**, **OS_FREEBSD**, or **OS_OPENBSD**. + !! + !! Note: This function performs a detailed runtime inspection, so it has non-negligible overhead. + + ! Local variables + character(len=255) :: val + integer :: length, rc + logical :: file_exists + + os = OS_UNKNOWN + + ! Check environment variable `OSTYPE`. + call get_environment_variable('OSTYPE', val, length, rc) + + if (rc == 0 .and. length > 0) then + ! Linux + if (index(val, 'linux') > 0) then + os = OS_LINUX + return + end if + + ! macOS + if (index(val, 'darwin') > 0) then + os = OS_MACOS + return + end if + + ! Windows, MSYS, MinGW, Git Bash + if (index(val, 'win') > 0 .or. index(val, 'msys') > 0) then + os = OS_WINDOWS + return + end if + + ! Cygwin + if (index(val, 'cygwin') > 0) then + os = OS_CYGWIN + return + end if + + ! Solaris, OpenIndiana, ... + if (index(val, 'SunOS') > 0 .or. index(val, 'solaris') > 0) then + os = OS_SOLARIS + return + end if + + ! FreeBSD + if (index(val, 'FreeBSD') > 0 .or. index(val, 'freebsd') > 0) then + os = OS_FREEBSD + return + end if + + ! OpenBSD + if (index(val, 'OpenBSD') > 0 .or. index(val, 'openbsd') > 0) then + os = OS_OPENBSD + return + end if + end if + + ! Check environment variable `OS`. + call get_environment_variable('OS', val, length, rc) + + if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then + os = OS_WINDOWS + return + end if + + ! Linux + inquire (file='/etc/os-release', exist=file_exists) + + if (file_exists) then + os = OS_LINUX + return + end if + + ! macOS + inquire (file='/usr/bin/sw_vers', exist=file_exists) + + if (file_exists) then + os = OS_MACOS + return + end if + + ! FreeBSD + inquire (file='/bin/freebsd-version', exist=file_exists) + + if (file_exists) then + os = OS_FREEBSD + return + end if +end function runtime_os + +!> Return string describing the OS type flag +pure function OS_NAME(os) + integer, intent(in) :: os + character(len=:), allocatable :: OS_NAME + + select case (os) + case (OS_LINUX); OS_NAME = "Linux" + case (OS_MACOS); OS_NAME = "macOS" + case (OS_WINDOWS); OS_NAME = "Windows" + case (OS_CYGWIN); OS_NAME = "Cygwin" + case (OS_SOLARIS); OS_NAME = "Solaris" + case (OS_FREEBSD); OS_NAME = "FreeBSD" + case (OS_OPENBSD); OS_NAME = "OpenBSD" + case default ; OS_NAME = "Unknown" + end select +end function OS_NAME + +!> Executes a synchronous shell command and optionally retrieves its outputs. +subroutine run(cmd, exit_state, command_state, stdout, stderr) + !> Command to execute as a string + character(len=*), intent(in) :: cmd + !> [optional] Exit state of the command + integer, intent(out), optional :: exit_state + !> [optional] Command state, indicating issues with command invocation + integer, intent(out), optional :: command_state + !> [optional] Captured standard output (stdout) + type(string_type), optional, intent(out) :: stdout + !> [optional] Captured standard error (stderr) + type(string_type), optional, intent(out) :: stderr + + !> Local variables + character(len=4096) :: iomsg + type(state_type) :: err + logical :: want_stdout, want_stderr + character(:), allocatable :: redirect_file + integer :: cstat, estat, fh, iostat + + want_stdout = present(stdout) + want_stderr = present(stderr) + iomsg = repeat(' ',4096) + + if (want_stdout) then + ! Redirect output to a file + redirect_file = scratch_name() + else + redirect_file = null_device() + endif + + ! Execute command + call execute_command_line(cmd//" >"//redirect_file//" 2>&1", wait = .true., exitstat=estat,cmdstat=cstat,cmdmsg=iomsg) + + ! Retrieve stdout, stderr + if (want_stdout) stdout = getfile(redirect_file,delete=.true.) + if (want_stderr) stderr = trim(iomsg) + + if (present(exit_state)) then + exit_state = estat + elseif (estat /= 0) then + call error_stop('Cannot run: '//cmd) + end if + + if (present(command_state)) then + command_state = cstat + elseif (cstat /= 0) then + call error_stop('Command error: '//cmd) + endif + + contains + + ! Simple timestamp-based temporary name generation + function scratch_name() result(temp_filename) + character(:), allocatable :: temp_filename + character(len=10) :: timestamp,yyyymmdd + + call date_and_time(date=yyyymmdd,time=timestamp) + + temp_filename = 'tmp_' // yyyymmdd(1:8) //'_'// timestamp(1:6) // '_' // timestamp(8:10) // '.tmp' + end function scratch_name + +end subroutine run + end module stdlib_system diff --git a/test/io/CMakeLists.txt b/test/io/CMakeLists.txt index 98794cd88..77a12c323 100644 --- a/test/io/CMakeLists.txt +++ b/test/io/CMakeLists.txt @@ -13,6 +13,7 @@ ADDTEST(savetxt_qp) set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision) set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision) +ADDTEST(filesystem) ADDTEST(getline) ADDTEST(npy) ADDTEST(open) diff --git a/test/io/existing_file.txt b/test/io/existing_file.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 new file mode 100644 index 000000000..afd26f882 --- /dev/null +++ b/test/io/test_filesystem.f90 @@ -0,0 +1,186 @@ +module test_filesystem + use stdlib_io_filesystem + use stdlib_error, only: state_type + use testdrive, only: new_unittest, unittest_type, error_type, check, test_failed + implicit none + private + + public :: collect_filesystem + + character(*), parameter :: temp_list_dir = 'temp_list_dir' + +contains + + !> Collect all exported unit tests + subroutine collect_filesystem(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + allocate(testsuite(0)) + + testsuite = [ & + new_unittest("fs_delete_non_existent", test_delete_file_non_existent), & + new_unittest("fs_delete_existing_file", test_delete_file_existing), & + new_unittest("fs_delete_file_being_dir", test_delete_directory), & + new_unittest("fs_is_directory_dir", test_is_directory_dir), & + new_unittest("fs_is_directory_file", test_is_directory_file) & + ] + + end subroutine collect_filesystem + + subroutine test_delete_file_non_existent(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + type(state_type) :: state + + ! Attempt to delete a file that doesn't exist + call delete_file('non_existent_file.txt', state) + + call check(error, state%error(), 'Error should be triggered for non-existent file') + if (allocated(error)) return + + end subroutine test_delete_file_non_existent + + subroutine test_delete_file_existing(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=256) :: filename + type(state_type) :: state + integer :: ios,iunit + logical :: is_present + character(len=512) :: msg + + filename = 'existing_file.txt' + + ! Create a file to be deleted + open(newunit=iunit, file=filename, status='replace', iostat=ios, iomsg=msg) + call check(error, ios==0, 'Failed to create test file') + if (allocated(error)) return + close(iunit) + + ! Attempt to delete the existing file + call delete_file(filename, state) + + ! Check deletion successful + call check(error, state%ok(), 'delete_file returned '//state%print()) + if (allocated(error)) return + + ! Check if the file was successfully deleted (should no longer exist) + inquire(file=filename, exist=is_present) + + call check(error, .not.is_present, 'File still present after delete') + if (allocated(error)) return + + end subroutine test_delete_file_existing + + subroutine test_delete_directory(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + character(len=256) :: filename + type(state_type) :: state + integer :: ios,iocmd + character(len=512) :: msg + + filename = 'test_directory' + + ! The directory is not nested: it should be cross-platform to just call `mkdir` + print *, 'mkdir' + call execute_command_line('mkdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios==0 .and. iocmd==0, 'Cannot init delete_directory test: '//trim(msg)) + if (allocated(error)) return + + ! Attempt to delete a directory (which should fail) + print *, 'dfelete' + call delete_file(filename, state) + + ! Check that an error was raised since the target is a directory + call check(error, state%error(), 'Error was not triggered trying to delete directory') + if (allocated(error)) return + + ! Clean up: remove the empty directory + print *, 'rmdir' + call execute_command_line('rmdir ' // filename, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios==0 .and. iocmd==0, 'Cannot cleanup delete_directory test: '//trim(msg)) + if (allocated(error)) return + + end subroutine test_delete_directory + + ! Test `is_directory` for a directory + subroutine test_is_directory_dir(error) + type(error_type), allocatable, intent(out) :: error + character(len=256) :: dirname + integer :: ios, iocmd + character(len=512) :: msg + + dirname = "this_test_dir_tmp" + + ! Create a directory + call execute_command_line("mkdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios == 0 .and. iocmd == 0, "Cannot create test directory: " // trim(msg)) + if (allocated(error)) return + + ! Verify `is_directory` identifies it as a directory + call check(error, is_directory(dirname), "is_directory did not recognize a valid directory") + if (allocated(error)) return + + ! Clean up: remove the directory + call execute_command_line("rmdir " // dirname, exitstat=ios, cmdstat=iocmd, cmdmsg=msg) + call check(error, ios == 0 .and. iocmd == 0, "Cannot remove test directory: " // trim(msg)) + end subroutine test_is_directory_dir + + ! Test `is_directory` for a regular file + subroutine test_is_directory_file(error) + type(error_type), allocatable, intent(out) :: error + character(len=256) :: filename + logical :: result + integer :: ios, iunit + character(len=512) :: msg + type(state_type) :: err + + filename = "test_file.txt" + + ! Create a file + open(newunit=iunit, file=filename, status="replace", iostat=ios, iomsg=msg) + call check(error, ios == 0, "Cannot create test file: " // trim(msg)) + if (allocated(error)) return + close(iunit) + + ! Verify `is_directory` identifies it as not a directory + result = is_directory(filename) + call check(error, .not. result, "is_directory falsely recognized a regular file as a directory") + if (allocated(error)) return + + ! Clean up: remove the file + call delete_file(filename, err) + call check(error, err%ok(), err%print()) + + end subroutine test_is_directory_file + +end module test_filesystem + +program test_all_filesystem + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_filesystem, only : collect_filesystem + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("filesystem", collect_filesystem) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end program test_all_filesystem diff --git a/test/io/test_getline.f90 b/test/io/test_getline.f90 index e035a904f..df1053f0a 100644 --- a/test/io/test_getline.f90 +++ b/test/io/test_getline.f90 @@ -1,6 +1,7 @@ module test_getline - use stdlib_io, only : getline - use stdlib_string_type, only : string_type, len + use stdlib_io, only : getline, getfile + use stdlib_error, only: state_type + use stdlib_string_type, only : string_type, len, len_trim use testdrive, only : new_unittest, unittest_type, error_type, check implicit none private @@ -20,7 +21,10 @@ subroutine collect_getline(testsuite) new_unittest("pad-no", test_pad_no), & new_unittest("iostat-end", test_iostat_end), & new_unittest("closed-unit", test_closed_unit, should_fail=.true.), & - new_unittest("no-unit", test_no_unit, should_fail=.true.) & + new_unittest("no-unit", test_no_unit, should_fail=.true.), & + new_unittest("getfile-no", test_getfile_missing), & + new_unittest("getfile-empty", test_getfile_empty), & + new_unittest("getfile-non-empty", test_getfile_non_empty) & ] end subroutine collect_getline @@ -139,6 +143,77 @@ subroutine test_no_unit(error) call check(error, stat, msg) end subroutine test_no_unit + subroutine test_getfile_missing(error) + !> Test for a missing file. + type(error_type), allocatable, intent(out) :: error + + type(string_type) :: fileContents + type(state_type) :: err + + fileContents = getfile("nonexistent_file.txt", err) + + ! Check that an error was returned + call check(error, err%error(), "Error not returned on a missing file") + if (allocated(error)) return + + end subroutine test_getfile_missing + + subroutine test_getfile_empty(error) + !> Test for an empty file. + type(error_type), allocatable, intent(out) :: error + + integer :: ios + character(len=:), allocatable :: filename + type(string_type) :: fileContents + type(state_type) :: err + + ! Get a temporary file name + filename = "test_getfile_empty.txt" + + ! Create an empty file + open(newunit=ios, file=filename, action="write", form="formatted", access="sequential") + close(ios) + + ! Read and delete it + fileContents = getfile(filename, err, delete=.true.) + + call check(error, err%ok(), "Should not return error reading an empty file") + if (allocated(error)) return + + call check(error, len_trim(fileContents) == 0, "String from empty file should be empty") + if (allocated(error)) return + + end subroutine test_getfile_empty + + subroutine test_getfile_non_empty(error) + !> Test for a non-empty file. + type(error_type), allocatable, intent(out) :: error + + integer :: ios + character(len=:), allocatable :: filename + type(string_type) :: fileContents + type(state_type) :: err + + ! Get a temporary file name + filename = "test_getfile_size5.txt" + + ! Create a fixed-size file + open(newunit=ios, file=filename, action="write", form="unformatted", access="stream") + write(ios) "12345" + close(ios) + + ! Read and delete it + fileContents = getfile(filename, err, delete=.true.) + + call check(error, err%ok(), "Should not return error reading a non-empty file") + if (allocated(error)) return + + call check(error, len_trim(fileContents) == 5, "Wrong string size returned") + if (allocated(error)) return + + end subroutine test_getfile_non_empty + + end module test_getline