diff --git a/CMakeLists.txt b/CMakeLists.txt index d83aa205c..09a1753e0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,7 +4,7 @@ cmake_minimum_required(VERSION 3.14.0) set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_CURRENT_SOURCE_DIR}/config/DefaultFlags.cmake) project(fortran_stdlib - LANGUAGES Fortran + LANGUAGES Fortran C DESCRIPTION "Community driven and agreed upon de facto standard library for Fortran" ) diff --git a/config/fypp_deployment.py b/config/fypp_deployment.py index 93e49d065..47459de64 100644 --- a/config/fypp_deployment.py +++ b/config/fypp_deployment.py @@ -105,7 +105,7 @@ def recursive_copy(folder): for root, _, files in os.walk(folder): for file in files: if file not in prune: - if file.endswith(".f90") or file.endswith(".F90") or file.endswith(".dat") or file.endswith(".npy"): + if file.endswith((".f90", ".F90", ".dat", ".npy", ".c")): shutil.copy2(os.path.join(root, file), base_folder+os.sep+folder+os.sep+file) recursive_copy('src') recursive_copy('test') diff --git a/doc/specs/index.md b/doc/specs/index.md index de3eb8f38..6057fd848 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -37,6 +37,7 @@ This is an index/directory of the specifications (specs) for each new module/fea - [string\_type](./stdlib_string_type.html) - Basic string support - [stringlist_type](./stdlib_stringlist_type.html) - 1-Dimensional list of strings - [strings](./stdlib_strings.html) - String handling and manipulation routines + - [system](./stdlib_system.html) - OS and sub-processing routines - [version](./stdlib_version.html) - Version information ## Released/Stable Features & Modules diff --git a/doc/specs/stdlib_strings.md b/doc/specs/stdlib_strings.md index 970800d4c..e95d25c97 100644 --- a/doc/specs/stdlib_strings.md +++ b/doc/specs/stdlib_strings.md @@ -498,6 +498,7 @@ The result is of the same type as the elements of `strings` (`type(string_type)` ``` + ### `to_string` #### Description diff --git a/doc/specs/stdlib_system.md b/doc/specs/stdlib_system.md new file mode 100644 index 000000000..0ab9e2e1d --- /dev/null +++ b/doc/specs/stdlib_system.md @@ -0,0 +1,337 @@ +--- +title: system +--- + +# System and sub-processing module + +The `stdlib_system` module provides interface for interacting with external processes, enabling the execution +and monitoring of system commands or applications directly from Fortran. + +[TOC] + +## `run` - Execute an external process synchronously + +### Status + +Experimental + +### Description + +The `run` interface allows execution of external processes using a single command string or a list of arguments. +Processes run synchronously, meaning execution is blocked until the process finishes. +Optional arguments enable the collection of standard output and error streams, as well as sending input via standard input. +Additionally, a callback function can be specified to execute upon process completion, optionally receiving a user-defined payload. + +### Syntax + +`process = ` [[stdlib_subprocess(module):run(interface)]] `(args [, stdin] [, want_stdout] [, want_stderr] [, callback] [, payload])` + +### Arguments + +`args`: Shall be a `character(*)` string (for command-line execution) or a `character(*), dimension(:)` array (for argument-based execution). It specifies the command and arguments to execute. This is an `intent(in)` argument. + +`stdin` (optional): Shall be a `character(*)` value containing input to send to the process via standard input (pipe). This is an `intent(in)` argument. + +`want_stdout` (optional): Shall be a `logical` flag. If `.true.`, the standard output of the process will be captured; if `.false.` (default), it will be lost. This is an `intent(in)` argument. + +`want_stderr` (optional): Shall be a `logical` flag. If `.true.`, the standard error output of the process will be captured. If `.false.` (default), it will be lost. This is an `intent(in)` argument. + +`callback` (optional): Shall be a procedure conforming to the `process_callback` interface. If present, this function will be called upon process completion with the process ID, exit state, and optionally collected standard input, output, and error streams. This is an `intent(in)` argument. + +`payload` (optional): Shall be a generic (`class(*)`) scalar that will be passed to the callback function upon process completion. It allows users to associate custom data with the process execution. This is an `intent(inout), target` argument. + +### Return Value + +Returns an object of type `process_type` that contains information about the state of the created process. + +### Example + +```fortran +! Example usage with command line or list of arguments +type(process_type) :: p + +! Run a simple command line synchronously +p = run("echo 'Hello, world!'", want_stdout=.true.) +``` + +## `runasync` - Execute an external process asynchronously + +### Status + +Experimental + +### Description + +The `runasync` interface allows execution of external processes using a single command string or a list of arguments. +Processes are run asynchronously (non-blocking), meaning execution does not wait for the process to finish. +Optional arguments enable the collection of standard output and error streams, as well as sending input via standard input. +Additionally, a callback function can be specified to execute upon process completion, optionally receiving a user-defined payload. + +### Syntax + +`process = ` [[stdlib_subprocess(module):runasync(interface)]] `(args [, stdin] [, want_stdout] [, want_stderr] [, callback] [, payload])` + +### Arguments + +`args`: Shall be a `character(*)` string (for command-line execution) or a `character(*), dimension(:)` array (for argument-based execution). It specifies the command and arguments to execute. This is an `intent(in)` argument. + +`stdin` (optional): Shall be a `character(*)` value containing input to send to the process via standard input (pipe). This is an `intent(in)` argument. + +`want_stdout` (optional): Shall be a `logical` flag. If `.true.`, the standard output of the process will be captured; if `.false.` (default), it will be lost. This is an `intent(in)` argument. + +`want_stderr` (optional): Shall be a `logical` flag. If `.true.`, the standard error output of the process will be captured. Default: `.false.`. This is an `intent(in)` argument. + +`callback` (optional): Shall be a procedure conforming to the `process_callback` interface. If present, this function will be called upon process completion with the process ID, exit state, and optionally collected standard input, output, and error streams. This is an `intent(in)` argument. + +`payload` (optional): Shall be a generic (`class(*)`) scalar that will be passed to the callback function upon process completion. It allows users to associate custom data with the process execution. This is an `intent(inout), target` argument. + +### Return Value + +Returns an object of type `process_type` that contains information about the state of the created process. + +### Example + +```fortran +{!example/system/example_process_1.f90!} +``` + +## `is_running` - Check if a process is still running + +### Status + +Experimental + +### Description + +The `is_running` interface provides a method to check if an external process is still running. +This is useful for monitoring the status of asynchronous processes created with the `run` interface. + +### Syntax + +`status = ` [[stdlib_subprocess(module):is_running(interface)]] `(process)` + +### Arguments + +`process`: Shall be a `type(process_type)` object representing the external process to check. This is an `intent(inout)` argument. + + +### Return Value + +Returns a `logical` value: `.true.` if the process is still running, or `.false.` if the process has terminated. +After a call to `is_running`, the `type(process_type)` structure is also updated to the latest process state. + +### Example + +```fortran +{!example/system/example_process_2.f90!} +``` + +## `is_completed` - Check if a process has completed execution + +### Status + +Experimental + +### Description + +The `is_completed` interface provides a method to check if an external process has finished execution. +This is useful for determining whether asynchronous processes created with the `run` interface have terminated. + +### Syntax + +`status = ` [[stdlib_subprocess(module):is_completed(interface)]] `(process)` + +### Arguments + +`process`: Shall be a `type(process_type)` object representing the external process to check. This is an `intent(inout)` argument. + +### Return Value + +Returns a `logical` value: +- `.true.` if the process has completed. +- `.false.` if the process is still running. + +After a call to `is_completed`, the `type(process_type)` structure is updated to reflect the latest process state. + +### Example + +```fortran +{!example/system/example_process_1.f90!} +``` + +## `elapsed` - Return process lifetime in seconds + +### Status + +Experimental + +### Description + +The `elapsed` interface provides a method to calculate the total time that has elapsed since a process was started. +This is useful for tracking the duration of an external process or for performance monitoring purposes. + +The result is a real value representing the elapsed time in seconds, measured from the time the process was created. + +### Syntax + +`delta_t = ` [[stdlib_subprocess(module):elapsed(subroutine)]] `(process)` + +### Arguments + +`process`: Shall be a `type(process_type)` object representing the external process. It is an `intent(in)` argument. + +### Return Value + +Returns a `real(real64)` value that represents the elapsed time (in seconds) since the process was started. +If the process is still running, the value returned is the time elapsed until the call to this function. +Otherwise, the total process duration from creation until completion is returned. + +### Example + +```fortran +{!example/system/example_process_3.f90!} +``` + +## `wait` - Wait until a running process is completed + +### Status + +Experimental + +### Description + +The `wait` interface provides a method to block the calling program until the specified process completes. +If the process is running asynchronously, this subroutine will pause the workflow until the given process finishes. +Additionally, an optional maximum wait time can be provided. If the process does not finish within the specified time, +the subroutine will return without waiting further. + +On return from this routine, the process state is accordingly updated. +This is useful when you want to wait for a background task to complete, but want to avoid indefinite blocking +in case of process hang or delay. + + +### Syntax + +`call ` [[stdlib_subprocess(module):wait(subroutine)]] `(process [, max_wait_time])` + +### Arguments + +`process`: Shall be a `type(process_type)` object representing the external process to monitor. +This is an `intent(inout)` argument, and its state is updated upon completion. + +`max_wait_time` (optional): Shall be a `real` value specifying the maximum wait time in seconds. +If not provided, the subroutine will wait indefinitely until the process completes. + +### Example + +```fortran +{!example/system/example_process_2.f90!} +``` + +## `update` - Update the internal state of a process + +### Status + +Experimental + +### Description + +The `update` interface allows the internal state of a process object to be updated by querying the system. +After the process completes, the standard output and standard error are retrieved, if they were requested, and loaded into the `process%stdout` and `process%stderr` string variables, respectively. + +This is especially useful for monitoring asynchronous processes and retrieving their output after they have finished. + +### Syntax + +`call ` [[stdlib_subprocess(module):update(subroutine)]] `(process)` + +### Arguments + +`process`: Shall be a `type(process_type)` object representing the external process whose state needs to be updated. +This is an `intent(inout)` argument, and its internal state is updated on completion. + +### Example + +```fortran +{!example/system/example_process_5.f90!} +``` + +## `kill` - Terminate a running process + +### Status + +Experimental + +### Description + +The `kill` interface is used to terminate a running external process. It attempts to stop the process and returns a boolean flag indicating whether the operation was successful. +This interface is useful when a process needs to be forcefully stopped, for example, if it becomes unresponsive or if its execution is no longer required. + +### Syntax + +`call ` [[stdlib_subprocess(module):kill(subroutine)]] `(process, success)` + +### Arguments + +`process`: Shall be a `type(process_type)` object representing the external process to be terminated. +This is an `intent(inout)` argument, and on return is updated with the terminated process state. + +`success`: Shall be a `logical` variable. It is set to `.true.` if the process was successfully killed, or `.false.` otherwise. + +### Example + +```fortran +{!example/system/example_process_4.f90!} +``` + +## `sleep` - Pause execution for a specified time in milliseconds + +### Status + +Experimental + +### Description + +The `sleep` interface pauses the execution of a program for a specified duration, given in milliseconds. +This routine acts as a cross-platform wrapper, abstracting the underlying platform-specific sleep implementations. +It ensures that the requested sleep duration is honored on both Windows and Unix-like systems. + +### Syntax + +`call ` [[stdlib_system(module):sleep(subroutine)]] `(millisec)` + +### Arguments + +`millisec`: Shall be an `integer` representing the number of milliseconds to sleep. This is an `intent(in)` argument. + +### Example + +```fortran +{!example/system/example_sleep.f90!} +``` + +## `is_windows` - Check if the system is running on Windows + +### Status + +Experimental + +### Description + +The `is_windows` interface provides a quick, compile-time check to determine if the current system is Windows. +It leverages a C function that checks for the presence of the `_WIN32` macro, which is defined in C compilers when targeting Windows. +This function is highly efficient and works during the compilation phase, avoiding the need for runtime checks. + +### Syntax + +`result = ` [[stdlib_system(module):is_windows(function)]] `()` + +### Return Value + +Returns a `logical` flag: `.true.` if the system is Windows, or `.false.` otherwise. + +### Example + +```fortran +{!example/system/example_process_1.f90!} +``` diff --git a/example/CMakeLists.txt b/example/CMakeLists.txt index cbef7f075..0abd204a7 100644 --- a/example/CMakeLists.txt +++ b/example/CMakeLists.txt @@ -30,4 +30,5 @@ add_subdirectory(stats_distribution_uniform) add_subdirectory(stringlist_type) add_subdirectory(strings) add_subdirectory(string_type) +add_subdirectory(system) add_subdirectory(version) diff --git a/example/system/CMakeLists.txt b/example/system/CMakeLists.txt new file mode 100644 index 000000000..5b4ef4054 --- /dev/null +++ b/example/system/CMakeLists.txt @@ -0,0 +1,8 @@ +ADD_EXAMPLE(process_1) +ADD_EXAMPLE(process_2) +ADD_EXAMPLE(process_3) +ADD_EXAMPLE(process_4) +ADD_EXAMPLE(process_5) +ADD_EXAMPLE(process_6) +ADD_EXAMPLE(process_7) +ADD_EXAMPLE(sleep) diff --git a/example/system/example_process_1.f90 b/example/system/example_process_1.f90 new file mode 100644 index 000000000..d0b416ba2 --- /dev/null +++ b/example/system/example_process_1.f90 @@ -0,0 +1,24 @@ +! Process example 1: Run a Command Synchronously and Capture Output +program run_sync + use stdlib_system, only: run, is_completed, is_windows, process_type + implicit none + + type(process_type) :: p + logical :: completed + + ! Run a synchronous process to list directory contents + if (is_windows()) then + p = run("dir", want_stdout=.true.) + else + p = run("ls -l", want_stdout=.true.) + end if + + ! Check if the process is completed (should be true since wait=.true.) + if (is_completed(p)) then + print *, "Process completed successfully. The current directory: " + print *, p%stdout + else + print *, "Process is still running (unexpected)." + end if + +end program run_sync diff --git a/example/system/example_process_2.f90 b/example/system/example_process_2.f90 new file mode 100644 index 000000000..df6c91f3d --- /dev/null +++ b/example/system/example_process_2.f90 @@ -0,0 +1,21 @@ +! Process example 2: Run an Asynchronous Command and check its status +program run_async + use stdlib_system, only: process_type, runasync, is_running, wait + implicit none + + type(process_type) :: p + + ! Run an asynchronous process to sleep for 1 second + p = runasync("sleep 1") + + ! Check if the process is running + if (is_running(p)) then + print *, "Process is running." + else + print *, "Process has already completed." + end if + + ! Wait for the process to complete + call wait(p, max_wait_time = 5.0) + print *, "Process has now completed." +end program run_async diff --git a/example/system/example_process_3.f90 b/example/system/example_process_3.f90 new file mode 100644 index 000000000..c5bc29056 --- /dev/null +++ b/example/system/example_process_3.f90 @@ -0,0 +1,22 @@ +! Process example 3: Run with many arguments, and check runtime +program run_with_args + use stdlib_system, only: process_type, run, elapsed, wait + implicit none + + type(process_type) :: p + character(len=15), allocatable :: args(:) + + ! Define arguments for the `echo` command + allocate(args(2)) + args(1) = "echo" + args(2) = "Hello, Fortran!" + + ! Run the command with arguments (synchronous) + p = run(args) + + ! Print the runtime of the process + print *, "Process runtime:", elapsed(p), "seconds." + + ! Clean up + deallocate(args) +end program run_with_args diff --git a/example/system/example_process_4.f90 b/example/system/example_process_4.f90 new file mode 100644 index 000000000..43c8a615b --- /dev/null +++ b/example/system/example_process_4.f90 @@ -0,0 +1,35 @@ +! Process example 4: Kill a running process +program example_process_kill + use stdlib_system, only: process_type, runasync, is_running, kill, elapsed, is_windows, sleep + implicit none + type(process_type) :: process + logical :: running, success + + print *, "Starting a long-running process..." + if (is_windows()) then + process = runasync("ping -n 10 127.0.0.1") + else + process = runasync("ping -c 10 127.0.0.1") + endif + + ! Verify the process is running + running = is_running(process) + print *, "Process running:", running + + ! Wait a bit before killing the process + call sleep(millisec=250) + + print *, "Killing the process..." + call kill(process, success) + + if (success) then + print *, "Process killed successfully." + else + print *, "Failed to kill the process." + endif + + ! Verify the process is no longer running + running = is_running(process) + print *, "Process running after kill:", running + +end program example_process_kill diff --git a/example/system/example_process_5.f90 b/example/system/example_process_5.f90 new file mode 100644 index 000000000..66d8e2ff8 --- /dev/null +++ b/example/system/example_process_5.f90 @@ -0,0 +1,28 @@ +! Process example 5: Object-oriented interface +program example_process_5 + use stdlib_system, only: process_type, runasync, is_windows, sleep, update + implicit none + type(process_type) :: process + + if (is_windows()) then + process = runasync("ping -n 10 127.0.0.1") + else + process = runasync("ping -c 10 127.0.0.1") + endif + + ! Verify the process is running + do while (process%is_running()) + + ! Update process state + call update(process) + + ! Wait a bit before killing the process + call sleep(millisec=1500) + + print *, "Process has been running for ",process%elapsed()," seconds..." + + end do + + print *, "Process ",process%pid()," completed in ",process%elapsed()," seconds." + +end program example_process_5 diff --git a/example/system/example_process_6.f90 b/example/system/example_process_6.f90 new file mode 100644 index 000000000..fa64d3044 --- /dev/null +++ b/example/system/example_process_6.f90 @@ -0,0 +1,45 @@ +! Process example 6: Demonstrate callback +program example_process_6 + use stdlib_system, only: process_type, process_ID, run, is_running, kill, elapsed, is_windows, sleep + implicit none + type(process_type) :: p + integer, target :: nfiles + + ! Run process, attach callback function and some data + if (is_windows()) then + p = run("dir",want_stdout=.true.,callback=get_dir_nfiles) + else + p = run("ls -l",want_stdout=.true.,callback=get_dir_nfiles,payload=nfiles) + endif + + ! On exit, the number of files should have been extracted by the callback function + print *, "Current directory has ",nfiles," files" + + contains + + ! Custom callback function: retrieve number of files from ls output + subroutine get_dir_nfiles(pid, exit_state, stdin, stdout, stderr, payload) + integer(process_ID), intent(in) :: pid + integer, intent(in) :: exit_state + character(len=*), optional, intent(in) :: stdin, stdout, stderr + class(*), optional, intent(inout) :: payload + + integer :: i + + if (present(payload)) then + + select type (nfiles => payload) + type is (integer) + if (present(stdout)) then + nfiles = count([ (stdout(i:i) == char(10), i=1,len(stdout)) ]) + else + nfiles = -1 + endif + class default + error stop 'Wrong payload passed to the process' + end select + + end if + end subroutine get_dir_nfiles + +end program example_process_6 diff --git a/example/system/example_process_7.f90 b/example/system/example_process_7.f90 new file mode 100644 index 000000000..91b441396 --- /dev/null +++ b/example/system/example_process_7.f90 @@ -0,0 +1,21 @@ +! Process example 7: Usage of `kill` +program example_process_7 + use stdlib_system, only: process_type, runasync, kill + implicit none + + type(process_type) :: p + logical :: success + + ! Start a process asynchronously + p = runasync("sleep 10") + + ! Attempt to kill the process + call kill(p, success) + + if (success) then + print *, "Process successfully killed." + else + print *, "Failed to kill the process." + end if + +end program example_process_7 diff --git a/example/system/example_sleep.f90 b/example/system/example_sleep.f90 new file mode 100644 index 000000000..75fdf165d --- /dev/null +++ b/example/system/example_sleep.f90 @@ -0,0 +1,13 @@ +! Usage of `sleep` +program example_sleep + use stdlib_system, only: sleep + implicit none + + print *, "Starting sleep..." + + ! Sleep for 500 milliseconds + call sleep(500) + + print *, "Finished sleeping!" + +end program example_sleep diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index d8a4ac1a9..05e445171 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -109,6 +109,8 @@ set(SRC stdlib_hashmap_open.f90 stdlib_logger.f90 stdlib_sorting_radix_sort.f90 + stdlib_system_subprocess.c + stdlib_system_subprocess.F90 stdlib_system.F90 stdlib_sparse.f90 stdlib_specialfunctions.f90 diff --git a/src/stdlib_strings.fypp b/src/stdlib_strings.fypp index d3e268e54..0d3904fbf 100644 --- a/src/stdlib_strings.fypp +++ b/src/stdlib_strings.fypp @@ -185,7 +185,6 @@ module stdlib_strings module procedure :: join_char end interface join - contains diff --git a/src/stdlib_system.F90 b/src/stdlib_system.F90 index 7bcc78baf..3c7858506 100644 --- a/src/stdlib_system.F90 +++ b/src/stdlib_system.F90 @@ -1,49 +1,433 @@ module stdlib_system -use, intrinsic :: iso_c_binding, only : c_int, c_long +use, intrinsic :: iso_c_binding, only : c_int, c_long, c_null_ptr, c_int64_t +use stdlib_kinds, only: int64, dp implicit none private public :: sleep -interface -#ifdef _WIN32 -subroutine winsleep(dwMilliseconds) bind (C, name='Sleep') -!! version: experimental -!! -!! void Sleep(DWORD dwMilliseconds) -!! https://docs.microsoft.com/en-us/windows/win32/api/synchapi/nf-synchapi-sleep -import c_long -integer(c_long), value, intent(in) :: dwMilliseconds -end subroutine winsleep -#else -integer(c_int) function usleep(usec) bind (C) -!! version: experimental -!! -!! int usleep(useconds_t usec); -!! https://linux.die.net/man/3/usleep -import c_int -integer(c_int), value, intent(in) :: usec -end function usleep -#endif -end interface +!> Public sub-processing interface +public :: run +public :: runasync +public :: process_type +public :: is_completed +public :: is_running +public :: update +public :: wait +public :: kill +public :: elapsed +public :: is_windows + +! CPU clock ticks storage +integer, parameter, private :: TICKS = int64 +integer, parameter, private :: RTICKS = dp +! Interoperable types to the C backend +integer, parameter, public :: process_ID = c_int64_t + +! Default flag for the runner process +integer(process_ID), parameter, private :: FORKED_PROCESS = 0_process_ID + +!> Process type holding process information and the connected stdout, stderr, stdin units +type :: process_type + + !> Process ID (if external); 0 if run by the program process + integer(process_ID) :: id = FORKED_PROCESS + + !> Process is completed + logical :: completed = .false. + integer(TICKS) :: start_time = 0 + + !> Standard input + character(:), allocatable :: stdin_file + character(:), allocatable :: stdin + + !> Standard output + character(:), allocatable :: stdout_file + character(:), allocatable :: stdout + + !> Error output + integer :: exit_code = 0 + character(:), allocatable :: stderr_file + character(:), allocatable :: stderr + + !> Callback function + procedure(process_callback), nopass, pointer :: oncomplete => null() + + !> Optional payload for the callback function + class(*), pointer :: payload => null() + + !> Store time at the last update + integer(TICKS) :: last_update = 0 + contains -subroutine sleep(millisec) -!! version: experimental -!! -integer, intent(in) :: millisec -integer(c_int) :: ierr + !! Check if process is still running + procedure :: is_running => process_is_running + + !! Check if process is completed + procedure :: is_completed => process_is_completed + + !! Return elapsed time since inception + procedure :: elapsed => process_lifetime + + !! Update process state internals + procedure :: update => update_process_state + + !! Kill a process + procedure :: kill => process_kill + + !! Get process ID + procedure :: pid => process_get_ID + +end type process_type + +interface runasync + !! version: experimental + !! + !! Executes an external process asynchronously. + !! ([Specification](../page/specs/stdlib_system.html#runasync-execute-an-external-process-asynchronously)) + !! + !! ### Summary + !! Provides methods for executing external processes asynchronously, using either a single command string + !! or an argument list, with options for output collection and standard input. + !! + !! ### Description + !! + !! This interface allows the user to spawn external processes asynchronously (non-blocking). + !! Processes can be executed via a single command string or a list of arguments, with options to collect + !! standard output and error streams, or to provide a standard input stream via a `character` string. + !! Additionally, a callback function can be provided, which will be called upon process completion. + !! A user-defined payload can be attached and passed to the callback for handling process-specific data. + !! + !! @note The implementation depends on system-level process management capabilities. + !! + module function run_async_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> The command line string to execute. + character(*), intent(in) :: cmd + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + + end function run_async_cmd + + module function run_async_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> List of arguments for the process to execute. + character(*), intent(in) :: args(:) + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + end function run_async_args +end interface runasync + +interface run + !! version: experimental + !! + !! Executes an external process synchronously. + !! ([Specification](../page/specs/stdlib_system.html#run-execute-an-external-process-synchronously)) + !! + !! ### Summary + !! Provides methods for executing external processes synchronously, using either a single command string + !! or an argument list, with options for output collection and standard input. + !! + !! ### Description + !! + !! This interface allows the user to spawn external processes synchronously (blocking), + !! via either a single command string or a list of arguments. It also includes options to collect + !! standard output and error streams, or to provide a standard input stream via a `character` string. + !! Additionally, it supports an optional callback function that is invoked upon process completion, + !! allowing users to process results dynamically. A user-defined payload can also be provided, + !! which is passed to the callback function to facilitate contextual processing. + !! + !! @note The implementation depends on system-level process management capabilities. + !! + module function run_sync_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> The command line string to execute. + character(*), intent(in) :: cmd + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + end function run_sync_cmd + + module function run_sync_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> List of arguments for the process to execute. + character(*), intent(in) :: args(:) + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + end function run_sync_args + +end interface run + +interface is_running + !! version: experimental + !! + !! Checks if an external process is still running. + !! ([Specification](../page/specs/stdlib_system.html#is_running-check-if-a-process-is-still-running)) + !! + !! ### Summary + !! Provides a method to determine if an external process is still actively running. + !! + !! ### Description + !! + !! This interface checks the status of an external process to determine whether it is still actively running. + !! It is particularly useful for monitoring asynchronous processes created using the `run` interface. + !! The internal state of the `process_type` object is updated after the call to reflect the current process status. + !! + !! @note The implementation relies on system-level process management capabilities. + !! + module logical function process_is_running(process) result(is_running) + !> The process object to check. + class(process_type), intent(inout) :: process + !> Logical result: `.true.` if the process is still running, `.false.` otherwise. + end function process_is_running +end interface is_running + + +interface is_completed + !! version: experimental + !! + !! Checks if an external process has completed execution. + !! ([Specification](../page/specs/stdlib_system.html#is_completed-check-if-a-process-has-completed-execution)) + !! + !! ### Summary + !! Provides a method to determine if an external process has finished execution. + !! + !! ### Description + !! + !! This interface checks the status of an external process to determine whether it has finished execution. + !! It is particularly useful for monitoring asynchronous processes created using the `run` interface. + !! The internal state of the `process_type` object is updated after the call to reflect the current process status. + !! + !! @note The implementation relies on system-level process management capabilities. + !! + module logical function process_is_completed(process) result(is_completed) + !> The process object to check. + class(process_type), intent(inout) :: process + !> Logical result: `.true.` if the process has completed, `.false.` otherwise. + end function process_is_completed +end interface is_completed + +interface elapsed + !! version: experimental + !! + !! Returns the lifetime of a process, in seconds. + !! ([Specification](../page/specs/stdlib_system.html#elapsed-return-process-lifetime-in-seconds)) + !! + !! ### Summary + !! Provides the total elapsed time (in seconds) since the creation of the specified process. + !! + !! ### Description + !! + !! This interface returns the total elapsed time (in seconds) for a given process since it was started. + !! If the process is still running, the value returned reflects the time from the creation of the process + !! until the call to this function. Otherwise, the total process duration until completion is returned. + !! + module function process_lifetime(process) result(delta_t) + !> The process object for which to calculate elapsed time. + class(process_type), intent(in) :: process + !> The elapsed time in seconds since the process started. + real(RTICKS) :: delta_t + end function process_lifetime +end interface elapsed + + +interface wait + !! version: experimental + !! + !! Waits for a running process to complete. + !! ([Specification](../page/specs/stdlib_system.html#wait-wait-until-a-running-process-is-completed)) + !! + !! ### Summary + !! Provides a method to block the execution and wait until the specified process finishes. + !! Supports an optional maximum wait time, after which the function returns regardless of process completion. + !! + !! ### Description + !! + !! This interface allows waiting for a process to complete. If the process is running asynchronously, this subroutine + !! will block further execution until the process finishes. Optionally, a maximum wait time can be specified; if + !! the process doesn't complete within this time, the subroutine returns without further waiting. + !! + !! @note The process state is accordingly updated on return from this call. + !! + module subroutine wait_for_completion(process, max_wait_time) + !> The process object to monitor. + class(process_type), intent(inout) :: process + !> Optional maximum wait time in seconds. If not provided, waits indefinitely. + real, optional, intent(in) :: max_wait_time + end subroutine wait_for_completion +end interface wait -#ifdef _WIN32 -!! PGI Windows, Ifort Windows, .... -call winsleep(int(millisec, c_long)) -#else -!! Linux, Unix, MacOS, MSYS2, ... -ierr = usleep(int(millisec * 1000, c_int)) -if (ierr/=0) error stop 'problem with usleep() system call' -#endif +interface update + !! version: experimental + !! + !! Updates the internal state of a process variable. + !! ([Specification](../page/specs/stdlib_system.html#update-update-the-internal-state-of-a-process)) + !! + !! ### Summary + !! Provides a method to query the system and update the internal state of the specified process variable. + !! + !! ### Description + !! + !! This subroutine queries the system to retrieve and update information about the state of the process. + !! Once the process is completed, and if standard output or standard error were requested, their respective + !! data is loaded into the `process%stdout` and `process%stderr` variables. This routine is useful for keeping + !! track of the latest state and output of a process, particularly for asynchronous processes. + !! + !! @note This subroutine should be called periodically for asynchronous processes to check their completion + !! and retrieve the output. + !! + module subroutine update_process_state(process) + !> The process object whose state needs to be updated. + class(process_type), intent(inout) :: process + end subroutine update_process_state +end interface update +interface kill + !! version: experimental + !! + !! Terminates a running process. + !! ([Specification](../page/specs/stdlib_system.html#kill-terminate-a-running-process)) + !! + !! ### Summary + !! Provides a method to kill or terminate a running process. + !! Returns a boolean flag indicating whether the termination was successful. + !! + !! ### Description + !! + !! This interface allows for the termination of an external process that is still running. + !! If the process is successfully killed, the `success` output flag is set to `.true.`, otherwise `.false.`. + !! This function is useful for controlling and managing processes that are no longer needed or for forcefully + !! stopping an unresponsive process. + !! + !! @note This operation may be system-dependent and could fail if the underlying user does not have + !! the necessary rights to kill a process. + !! + module subroutine process_kill(process, success) + !> The process object to be terminated. + class(process_type), intent(inout) :: process + !> Boolean flag indicating whether the termination was successful. + logical, intent(out) :: success + end subroutine process_kill +end interface kill + +interface sleep + !! version: experimental + !! + !! Pauses execution for a specified time in milliseconds. + !! ([Specification](../page/specs/stdlib_system.html#sleep-pause-execution-for-a-specified-time=in-milliseconds)) + !! + !! ### Summary + !! Pauses code execution for a specified number of milliseconds. This routine is a cross-platform + !! wrapper around platform-specific sleep functions, providing consistent behavior on different operating systems. + !! + !! ### Description + !! + !! This interface allows the user to pause the execution of a program for a specified duration, expressed in + !! milliseconds. It provides a cross-platform wrapper around native sleep functions, ensuring that the program + !! will sleep for the requested amount of time on different systems (e.g., using `Sleep` on Windows or `nanosleep` + !! on Unix-like systems). + !! + !! @note The precision of the sleep may vary depending on the system and platform. + !! + module subroutine sleep(millisec) + !> The number of milliseconds to pause execution for. + integer, intent(in) :: millisec + end subroutine sleep +end interface sleep + +abstract interface -end subroutine sleep + !! version: experimental + !! + !! Process callback interface + !! + !! ### Summary + !! + !! The `process_callback` interface defines a user-provided subroutine that will be called + !! upon process completion. It provides access to process metadata, including the process ID, + !! exit state, and optional input/output streams. If passed on creation, a generic payload can be + !! accessed by the callback function. This variable must be a valid `target` in the calling scope. + !! + subroutine process_callback(pid,exit_state,stdin,stdout,stderr,payload) + import process_ID + implicit none + !> Process ID + integer(process_ID), intent(in) :: pid + !> Process return state + integer, intent(in) :: exit_state + !> Process input/output: presence of these arguments depends on how process was created + character(len=*), optional, intent(in) :: stdin,stdout,stderr + !> Optional payload passed by the user on process creation + class(*), optional, intent(inout) :: payload + end subroutine process_callback +end interface + +interface + + !! version: experimental + !! + !! Returns a `logical` flag indicating if the system is Windows. + !! ([Specification](../page/specs/stdlib_system.html#is_windows-check-if-the-system-is-running-on-windows)) + !! + !! ### Summary + !! A fast, compile-time check to determine if the system is running Windows, based on the `_WIN32` macro. + !! + !! ### Description + !! + !! This interface provides a function to check if the current system is Windows. The check is performed by + !! wrapping a C function that tests if the `_WIN32` macro is defined. This check is fast and occurs at + !! compile-time, making it a more efficient alternative to platform-specific runtime checks. + !! + !! The `is_windows` function is particularly useful for conditional compilation or system-specific code paths + !! that are dependent on whether the code is running on Windows. + !! + !! @note This function relies on the `_WIN32` macro, which is defined in C compilers when targeting Windows. + !! + module logical function is_windows() + end function is_windows + + module function process_get_ID(process) result(ID) + class(process_type), intent(in) :: process + !> Return a process ID + integer(process_ID) :: ID + end function process_get_ID + +end interface end module stdlib_system diff --git a/src/stdlib_system_subprocess.F90 b/src/stdlib_system_subprocess.F90 new file mode 100644 index 000000000..00f5d759a --- /dev/null +++ b/src/stdlib_system_subprocess.F90 @@ -0,0 +1,763 @@ +submodule (stdlib_system) stdlib_system_subprocess + use iso_c_binding + use iso_fortran_env, only: int64, real64 + use stdlib_strings, only: to_c_char, join + use stdlib_linalg_state, only: linalg_state_type, LINALG_ERROR, linalg_error_handling + implicit none(type, external) + + ! Number of CPU ticks between status updates + integer(TICKS), parameter :: CHECK_EVERY_TICKS = 100 + + ! Interface to C support functions from stdlib_system_subprocess.c + interface + + ! C wrapper to query process status + subroutine process_query_status(pid, wait, is_running, exit_code) & + bind(C, name='process_query_status') + import c_int, c_bool, process_ID + implicit none + ! Process ID + integer(process_ID), value :: pid + ! Whether to wait for process completion + logical(c_bool), value :: wait + ! Whether the process is still running + logical(c_bool), intent(out) :: is_running + ! Process exit code (or error code) + integer(c_int), intent(out) :: exit_code + end subroutine process_query_status + + subroutine process_create(cmd, stdin_stream, stdin_file, stdout_file, stderr_file, pid) & + bind(C, name='process_create') + import c_char, process_ID + implicit none + character(c_char), intent(in) :: cmd(*) + character(c_char), intent(in), optional :: stdin_stream(*) + character(c_char), intent(in), optional :: stdin_file(*) + character(c_char), intent(in), optional :: stdout_file(*) + character(c_char), intent(in), optional :: stderr_file(*) + integer(process_ID), intent(out) :: pid + end subroutine process_create + + logical(c_bool) function process_system_kill(pid) bind(C, name='process_kill') + import c_bool, process_ID + implicit none + integer(process_ID), intent(in), value :: pid + end function process_system_kill + + ! System implementation of a wait function + subroutine process_wait(seconds) bind(C,name='process_wait') + import c_float + implicit none + real(c_float), intent(in), value :: seconds + end subroutine process_wait + + ! Return path to the null device + type(c_ptr) function process_null_device(len) bind(C,name='process_null_device') + import c_ptr, c_int + implicit none + integer(c_int), intent(out) :: len + end function process_null_device + + ! Utility: check if _WIN32 is defined in the C compiler + logical(c_bool) function process_is_windows() bind(C,name='process_is_windows') + import c_bool + implicit none + end function process_is_windows + + end interface + + ! C boolean constants + logical(c_bool), parameter :: C_FALSE = .false._c_bool + logical(c_bool), parameter :: C_TRUE = .true._c_bool + +contains + + ! Call system-dependent wait implementation + module subroutine sleep(millisec) + integer, intent(in) :: millisec + + real(c_float) :: seconds + + seconds = 0.001_c_float*max(0,millisec) + + call process_wait(seconds) + + end subroutine sleep + + module function run_async_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> The command line string to execute. + character(*), intent(in) :: cmd + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + + process = process_open([cmd],.false.,stdin,want_stdout,want_stderr,callback,payload) + + end function run_async_cmd + + module function run_async_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> List of arguments for the process to execute. + character(*), intent(in) :: args(:) + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + + process = process_open(args,.false.,stdin,want_stdout,want_stderr,callback,payload) + + end function run_async_args + + module function run_sync_cmd(cmd, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> The command line string to execute. + character(*), intent(in) :: cmd + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + + process = process_open([cmd],.true.,stdin,want_stdout,want_stderr,callback,payload) + + end function run_sync_cmd + + module function run_sync_args(args, stdin, want_stdout, want_stderr, callback, payload) result(process) + !> List of arguments for the process to execute. + character(*), intent(in) :: args(:) + !> Optional input sent to the process via standard input (stdin). + character(*), optional, intent(in) :: stdin + !> Whether to collect standard output. + logical, optional, intent(in) :: want_stdout + !> Whether to collect standard error output. + logical, optional, intent(in) :: want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler. + type(process_type) :: process + + process = process_open(args,.true.,stdin,want_stdout,want_stderr,callback,payload) + + end function run_sync_args + + !> Internal function: open a new process from a command line + function process_open_cmd(cmd,wait,stdin,want_stdout,want_stderr,callback,payload) result(process) + !> The command and arguments + character(*), intent(in) :: cmd + !> Optional character input to be sent to the process via pipe + character(*), optional, intent(in) :: stdin + !> Define if the process should be synchronous (wait=.true.), or asynchronous(wait=.false.) + logical, intent(in) :: wait + !> Require collecting output + logical, optional, intent(in) :: want_stdout, want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler + type(process_type) :: process + + process = process_open([cmd],wait,stdin,want_stdout,want_stderr,callback,payload) + + end function process_open_cmd + + !> Internal function: open a new process from arguments + function process_open(args,wait,stdin,want_stdout,want_stderr,callback,payload) result(process) + !> The command and arguments + character(*), intent(in) :: args(:) + !> Optional character input to be sent to the process via pipe + character(*), optional, intent(in) :: stdin + !> Define if the process should be synchronous (wait=.true.), or asynchronous(wait=.false.) + logical, intent(in) :: wait + !> Require collecting output + logical, optional, intent(in) :: want_stdout, want_stderr + !> Optional callback function to be called on process completion + procedure(process_callback), optional :: callback + !> Optional payload to pass to the callback on completion + class(*), optional, intent(inout), target :: payload + !> The output process handler + type(process_type) :: process + + real(RTICKS) :: count_rate + logical :: asynchronous, collect_stdout, collect_stderr, has_stdin + integer :: command_state, exit_state + integer(TICKS) :: count_max + + ! Process user requests + asynchronous = .not.wait + collect_stdout = .false. + collect_stderr = .false. + has_stdin = present(stdin) + if (present(want_stdout)) collect_stdout = want_stdout + if (present(want_stderr)) collect_stderr = want_stderr + + ! Attach stdout to a scratch file (must be named) + if (has_stdin) process%stdin_file = scratch_name('inp') + if (collect_stdout) process%stdout_file = scratch_name('out') + if (collect_stderr) process%stderr_file = scratch_name('err') + + ! Attach callback function and payload + if (present(callback)) then + process%oncomplete => callback + else + nullify(process%oncomplete) + end if + + if (present(payload)) then + process%payload => payload + else + nullify(process%payload) + end if + + ! Save the process's generation time + call system_clock(process%start_time,count_rate,count_max) + process%last_update = process%start_time + + if (asynchronous) then + + ! Create or fork a new process, store pid + call launch_asynchronous(process, args, stdin) + + else + + ! No need to create an external process + process%id = FORKED_PROCESS + + endif + + if (process%id == FORKED_PROCESS) then + + ! Launch to completion from the local process + call launch_synchronous(process, args, stdin) + call save_completed_state(process,delete_files=.not.asynchronous) + + ! If the process was forked + ! Note: use `exit` rather than `stop` to prevent the mandatory stdout STOP message + if (asynchronous) then + if (command_state/=0) then + ! Invalid command: didn't even start + call exit(command_state) + else + ! Return exit state + call exit(exit_state) + end if + endif + + endif + + ! Run a first update + call update_process_state(process) + + end function process_open + + subroutine launch_asynchronous(process, args, stdin) + class(process_type), intent(inout) :: process + !> The command and arguments + character(*), intent(in) :: args(:) + !> Optional character input to be sent to the process via pipe + character(*), optional, intent(in) :: stdin + + character(c_char), dimension(:), allocatable, target :: c_cmd,c_stdin,c_stdin_file,c_stdout_file,c_stderr_file + + ! Assemble C strings + c_cmd = to_c_char(join(args)) + if (present(stdin)) c_stdin = to_c_char(stdin) + if (allocated(process%stdin_file)) c_stdin_file = to_c_char(process%stdin_file) + if (allocated(process%stdout_file)) c_stdout_file = to_c_char(process%stdout_file) + if (allocated(process%stderr_file)) c_stderr_file = to_c_char(process%stderr_file) + + ! On Windows, this 1) creates 2) launches an external process from C. + ! On unix, this 1) forks an external process + call process_create(c_cmd, c_stdin, c_stdin_file, c_stdout_file, c_stderr_file, process%id) + + end subroutine launch_asynchronous + + subroutine launch_synchronous(process, args, stdin) + class(process_type), intent(inout) :: process + !> The command and arguments + character(*), intent(in) :: args(:) + !> Optional character input to be sent to the process via pipe + character(*), optional, intent(in) :: stdin + + character(:), allocatable :: cmd + character(4096) :: iomsg + integer :: iostat,estat,cstat,stdin_unit + logical :: has_stdin + + has_stdin = present(stdin) + + ! Prepare stdin + if (has_stdin) then + + open(newunit=stdin_unit,file=process%stdin_file, & + access='stream',action='write',position='rewind', & + iostat=iostat,iomsg=iomsg) + if (iostat/=0) error stop 'cannot open temporary stdin' + + write(stdin_unit,iostat=iostat,iomsg=iomsg) stdin + if (iostat/=0) error stop trim(iomsg) + + close(stdin_unit,iostat=iostat,iomsg=iomsg,status='keep') + if (iostat/=0) error stop 'cannot close temporary stdin' + + end if + + ! Run command + cmd = assemble_cmd(args,process%stdin_file,process%stdout_file,process%stderr_file) + + ! Execute command + call execute_command_line(cmd,wait=.true.,exitstat=estat,cmdstat=cstat) + + ! Save state and output + process%exit_code = merge(cstat,estat,cstat/=0) + + end subroutine launch_synchronous + + !> Return the current (or total) process lifetime, in seconds + module real(RTICKS) function process_lifetime(process) result(delta_t) + class(process_type), intent(in) :: process + + real(RTICKS) :: ticks_per_second + integer(TICKS) :: current_time,count_max + + ! Get current time + call system_clock(current_time,ticks_per_second,count_max) + + if (process%completed) then + + delta_t = real(process%last_update-process%start_time,RTICKS)/ticks_per_second + + else + + delta_t = real(current_time-process%start_time,RTICKS)/ticks_per_second + + end if + + end function process_lifetime + + !> Wait for a process to be completed + module subroutine wait_for_completion(process, max_wait_time) + class(process_type), intent(inout) :: process + ! Optional max wait time in seconds + real, optional, intent(in) :: max_wait_time + + integer :: sleep_interval + real(RTICKS) :: wait_time, elapsed + integer(TICKS) :: start_time, current_time, count_rate + + ! Sleep interval ms + integer, parameter :: MIN_WAIT_MS = 1 + integer, parameter :: MAX_WAIT_MS = 100 + + ! Starting sleep interval: 1ms + sleep_interval = MIN_WAIT_MS + + ! Determine the wait time + if (present(max_wait_time)) then + wait_time = max(0.0_RTICKS, max_wait_time) + else + ! No limit if max_wait_time is not provided + wait_time = huge(wait_time) + end if + + ! Get the system clock rate and the start time + call system_clock(start_time, count_rate) + elapsed = 0.0_real64 + + ! Wait loop + wait_loop: do while (process_is_running(process) .and. elapsed <= wait_time) + + ! Small sleep to avoid CPU hogging, with exponential backoff (1 ms) + ! from 1ms up to 100ms + call sleep(millisec=sleep_interval) + sleep_interval = min(sleep_interval*2, MAX_WAIT_MS) + + call system_clock(current_time) + elapsed = real(current_time - start_time, RTICKS) / count_rate + + end do wait_loop + + end subroutine wait_for_completion + + !> Update a process's state, and save it to the process variable + module subroutine update_process_state(process) + class(process_type), intent(inout) :: process + + real(RTICKS) :: count_rate + integer(TICKS) :: count_max,current_time + logical(c_bool) :: running + integer(c_int) :: exit_code + + ! If the process has completed, should not be queried again + if (process%completed) return + + ! Save the process's generation time + call system_clock(current_time,count_rate,count_max) + + ! Only trigger an update after at least 100 count units + if (abs(real(current_time-process%last_update,RTICKS)) Live check if a process is running + module logical function process_is_running(process) result(is_running) + class(process_type), intent(inout) :: process + + ! Each evaluation triggers a state update + call update_process_state(process) + + is_running = .not.process%completed + + end function process_is_running + + !> Live check if a process has completed + module logical function process_is_completed(process) result(is_completed) + class(process_type), intent(inout) :: process + + ! Each evaluation triggers a state update + call update_process_state(process) + + is_completed = process%completed + + end function process_is_completed + + function scratch_name(prefix) result(temp_filename) + character(*), optional, intent(in) :: prefix + character(:), allocatable :: temp_filename + character(len=8) :: date + character(len=10) :: time + character(len=7) :: rand_str + real :: rrand + integer :: rand_val + + ! Get the current date and time + call date_and_time(date=date, time=time) + + ! Generate a random number for additional uniqueness + call random_number(rrand) + rand_val = nint(rrand * 1e6) ! Scale random number + write(rand_str,'(i7.7)') rand_val + + ! Construct the filename + if (present(prefix)) then + temp_filename = trim(prefix)// '_' // date // '_' // time(1:6) // '_' // rand_str // '.tmp' + else + temp_filename = 'tmp_' // date // '_' // time(1:6) // '_' // rand_str // '.tmp' + endif + + end function scratch_name + + + !> Assemble a single-line proces command line from a list of arguments. + !> + !> Version: Helper function. + function assemble_cmd(args, stdin, stdout, stderr) result(cmd) + !> Command to execute as a string + character(len=*), intent(in) :: args(:) + !> [optional] File name standard input (stdin) should be taken from + character(len=*), optional, intent(in) :: stdin + !> [optional] File name standard output (stdout) should be directed to + character(len=*), optional, intent(in) :: stdout + !> [optional] File name error output (stderr) should be directed to + character(len=*), optional, intent(in) :: stderr + + character(:), allocatable :: cmd,stdout_file,input_file,stderr_file + + if (present(stdin)) then + input_file = stdin + else + input_file = null_device() + end if + + if (present(stdout)) then + ! Redirect output to a file + stdout_file = stdout + else + stdout_file = null_device() + endif + + if (present(stderr)) then + stderr_file = stderr + else + stderr_file = null_device() + end if + + cmd = join(args)//" <"//input_file//" 1>"//stdout_file//" 2>"//stderr_file + + end function assemble_cmd + + !> Returns the file path of the null device for the current operating system. + !> + !> Version: Helper function. + function null_device() + character(:), allocatable :: null_device + + integer(c_int) :: i, len + type(c_ptr) :: c_path_ptr + character(kind=c_char), pointer :: c_path(:) + + ! Call the C function to get the null device path and its length + c_path_ptr = process_null_device(len) + call c_f_pointer(c_path_ptr,c_path,[len]) + + ! Allocate the Fortran string with the length returned from C + allocate(character(len=len) :: null_device) + + do concurrent (i=1:len) + null_device(i:i) = c_path(i) + end do + + end function null_device + + !> Returns the file path of the null device for the current operating system. + !> + !> Version: Helper function. + module logical function is_windows() + is_windows = logical(process_is_windows()) + end function is_windows + + !> Reads a whole ASCII file and loads its contents into an allocatable character string.. + !> The function handles error states and optionally deletes the file after reading. + !> Temporarily uses `linalg_state_type` in lieu of the generalized `state_type`. + !> + !> Version: to be replaced after `getfile` is standardized in `stdlib_io`. + 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(linalg_state_type), optional, intent(out) :: err + !> [optional] Delete file after reading? Default: do not delete + logical, optional, intent(in) :: delete + !> Return as an allocatable string + character(:), allocatable :: file + + ! Local variables + character(*), parameter :: CRLF = achar(13)//new_line('a') + type(linalg_state_type) :: err0 + character(len=:), allocatable :: fileString + character(len=512) :: iomsg + character :: last_char + 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 = linalg_state_type('getfile',LINALG_ERROR,'File not present:',fileName) + call linalg_error_handling(err0,err) + return + end if + + !> Retrieve file size + inquire(file=fileName,size=fileSize) + + invalid_size: if (fileSize<0) then + + err0 = linalg_state_type('getfile',LINALG_ERROR,fileName,'has invalid size=',fileSize) + call linalg_error_handling(err0,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 = linalg_state_type('getfile',LINALG_ERROR,'Cannot open',fileName,'for read:',iomsg) + call linalg_error_handling(err0,err) + return + end if + + remove_trailing_newline: if (fileSize>0) then + + last_char = CRLF(1:1) + fileSize = fileSize+1 + + do while (scan(last_char,CRLF)>0 .and. fileSize>1) + fileSize = fileSize-1 + read(lun, pos=fileSize, iostat=iostat, iomsg=iomsg) last_char + + ! Read error + if (iostat/=0) then + + err0 = linalg_state_type('getfile',LINALG_ERROR,iomsg,'(',fileName,'at byte',fileSize,')') + call linalg_error_handling(err0,err) + return + + endif + + end do + endif remove_trailing_newline + + 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 = linalg_state_type('getfile',LINALG_ERROR,iomsg,'(',fileName,'at byte',errpos,')') + call linalg_error_handling(err0,err) + return + + endif + + end if read_data + + if (want_deleted) then + close(lun,iostat=iostat,status='delete') + if (iostat/=0) err0 = linalg_state_type('getfile',LINALG_ERROR,'Cannot delete',fileName,'after reading') + else + close(lun,iostat=iostat) + if (iostat/=0) err0 = linalg_state_type('getfile',LINALG_ERROR,'Cannot close',fileName,'after reading') + endif + + ! Process output + call move_alloc(from=fileString,to=file) + call linalg_error_handling(err0,err) + + end function getfile + + !> Return process ID + module function process_get_ID(process) result(ID) + class(process_type), intent(in) :: process + !> Return a process ID + integer(process_ID) :: ID + ID = process%id + end function process_get_ID + +end submodule stdlib_system_subprocess diff --git a/src/stdlib_system_subprocess.c b/src/stdlib_system_subprocess.c new file mode 100644 index 000000000..59f010ddd --- /dev/null +++ b/src/stdlib_system_subprocess.c @@ -0,0 +1,399 @@ +#include +#include +#include +#include +#include +#include + +#ifdef _WIN32 +#include +#else +#define _POSIX_C_SOURCE 199309L +#include +#include +#include +#include +#include +#endif // _WIN32 + +// Typedefs +typedef void* stdlib_handle; +typedef int64_t stdlib_pid; + + +///////////////////////////////////////////////////////////////////////////////////// +// Windows-specific code +///////////////////////////////////////////////////////////////////////////////////// +#ifdef _WIN32 + +// On Windows systems: create a new process +void process_create_windows(const char* cmd, const char* stdin_stream, + const char* stdin_file, const char* stdout_file, const char* stderr_file, + stdlib_pid* pid) { + + STARTUPINFO si; + PROCESS_INFORMATION pi; + HANDLE hStdout = NULL, hStderr = NULL; + SECURITY_ATTRIBUTES sa = { sizeof(SECURITY_ATTRIBUTES), NULL, TRUE }; + FILE* stdin_fp = NULL; + + // Initialize null handle + (*pid) = 0; + + ZeroMemory(&si, sizeof(si)); + si.cb = sizeof(STARTUPINFO); + + // If possible, we redirect stdout/stderr to file handles directly. + // This will override any cmd redirection settings (<>). For stdin + + // Write stdin_stream to stdin_file if provided + if (stdin_stream && stdin_file) { + stdin_fp = fopen(stdin_file, "w"); + if (!stdin_fp) { + fprintf(stderr, "Failed to open stdin file for writing\n"); + return; + } + fputs(stdin_stream, stdin_fp); + fclose(stdin_fp); + } + + // Open stdout file if provided, otherwise use the null device + if (stdout_file) { + hStdout = CreateFile(stdout_file, GENERIC_WRITE, 0, &sa, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + if (hStdout == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Failed to open stdout file\n"); + return; + } + } else { + hStdout = CreateFile("NUL", GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (hStdout == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Failed to open null device for stdout\n"); + return; + } + } + si.hStdOutput = hStdout; + si.dwFlags |= STARTF_USESTDHANDLES; + + // Open stderr file if provided, otherwise use the null device + if (stderr_file) { + hStderr = CreateFile(stderr_file, GENERIC_WRITE, 0, &sa, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + if (hStderr == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Failed to open stderr file\n"); + return; + } + } else { + hStderr = CreateFile("NUL", GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (hStderr == INVALID_HANDLE_VALUE) { + fprintf(stderr, "Failed to open null device for stderr\n"); + return; + } + } + si.hStdError = hStderr; + si.dwFlags |= STARTF_USESTDHANDLES; + + // Prepare the command line with redirected stdin + char* full_cmd; + size_t cmd_len = strlen(cmd); + size_t stdin_len = stdin_file ? strlen(stdin_file) : 0; + size_t full_cmd_len = cmd_len + stdin_len + 5; + full_cmd = (char*)malloc(full_cmd_len); + if (!full_cmd) { + fprintf(stderr, "Failed to allocate memory for full_cmd\n"); + return; + } + + // Use full_cmd as needed (e.g., pass to CreateProcess) + if (stdin_file) { + snprintf(full_cmd, full_cmd_len, "%s < %s", cmd, stdin_file); + } else { + snprintf(full_cmd, full_cmd_len, "%s", cmd); + } + + // Create the process + BOOL success = CreateProcess( + NULL, // Application name + full_cmd, // Command line + NULL, // Process security attributes + NULL, // Thread security attributes + TRUE, // Inherit handles + 0, // Creation flags + NULL, // Environment variables + NULL, // Current directory + &si, // STARTUPINFO + &pi // PROCESS_INFORMATION + ); + + // Free the allocated memory + free(full_cmd); + + if (!success) { + fprintf(stderr, "CreateProcess failed (%lu).\n", GetLastError()); + return; + } + + // Close unneeded handles + if (hStdout) CloseHandle(hStdout); + if (hStderr) CloseHandle(hStderr); + + // Return the process handle for status queries + CloseHandle(pi.hThread); // Close the thread handle + (*pid) = (stdlib_pid) pi.dwProcessId; + +} + +// Query process state on a Windows system +void process_query_status_windows(stdlib_pid pid, bool wait, bool* is_running, int* exit_code) +{ + int wait_code; + HANDLE hProcess; + DWORD dwExitCode,dwPid; + + dwPid = (DWORD) pid; + + // Open the process with the appropriate access rights + hProcess = OpenProcess(PROCESS_QUERY_INFORMATION | SYNCHRONIZE, FALSE, dwPid); + + // Error opening the process, likely pid does not exist + if (hProcess == NULL) { + *is_running = false; + *exit_code = -1; + return; + } + + + if (wait) { + // Wait for the process to terminate + wait_code = WaitForSingleObject(hProcess, INFINITE); + } else { + // Check if the process has terminated + wait_code = WaitForSingleObject(hProcess, 0); + } + + if (wait_code == WAIT_OBJECT_0) { + // Process has exited, get the exit code + *is_running = false; + if (GetExitCodeProcess(hProcess, &dwExitCode)) { + *exit_code = dwExitCode; + } else { + *exit_code = -1; // Error retrieving the exit code + } + } else if (wait_code == WAIT_TIMEOUT) { + // Process is still running + *is_running = true; + *exit_code = 0; + } else { // WAIT_FAILED + // Error occurred + *is_running = false; + *exit_code = -1; // Error occurred in WaitForSingleObject + } + + // Close the process handle + CloseHandle(hProcess); +} + +// Kill a process on Windows by sending a PROCESS_TERMINATE signal. +// Return true if the operation succeeded, or false if it failed (process does not +// exist anymore, or we may not have the rights to kill the process). +bool process_kill_windows(stdlib_pid pid) { + HANDLE hProcess; + DWORD dwPid; + + dwPid = (DWORD) pid; + + // Open the process with terminate rights + hProcess = OpenProcess(PROCESS_TERMINATE, FALSE, dwPid); + + if (hProcess == NULL) { + // Failed to open the process; return false + return false; + } + + // Attempt to terminate the process + if (!TerminateProcess(hProcess, 1)) { + // Failed to terminate the process + CloseHandle(hProcess); + return false; + } + + // Successfully terminated the process + CloseHandle(hProcess); + return true; +} + + +#else // _WIN32 + +///////////////////////////////////////////////////////////////////////////////////// +// Unix-specific code +///////////////////////////////////////////////////////////////////////////////////// +void process_query_status_unix(stdlib_pid pid, bool wait, bool* is_running, int* exit_code) +{ + int status; + int wait_code; + + // Wait or return immediately if no status change + int options = wait ? 0 : WNOHANG; + + // Call waitpid to check the process state + wait_code = waitpid(pid, &status, options); + + if (wait_code > 0) { + // Process state was updated + if (WIFEXITED(status)) { + *is_running = false; + + // Get exit code + *exit_code = WEXITSTATUS(status); + } else if (WIFSIGNALED(status)) { + *is_running = false; + + // Use negative value to indicate termination by signal + *exit_code = -WTERMSIG(status); + } else { + // Process is still running: no valid exit code yet + *is_running = true; + *exit_code = 0; + } + } else if (wait_code == 0) { + // No status change; process is still running + *is_running = true; + *exit_code = 0; + } else { + // Error occurred + *is_running = false; + *exit_code = -1; // Indicate an error + } +} + +// Kill a process by sending a SIGKILL signal. Return .true. if succeeded, or false if not. +// Killing process may fail due to unexistent process, or not enough rights to kill. +bool process_kill_unix(stdlib_pid pid) { + // Send the SIGKILL signal to the process + if (kill(pid, SIGKILL) == 0) { + // Successfully sent the signal + return true; + } + + // If `kill` fails, check if the process no longer exists + if (errno == ESRCH) { + // Process does not exist + return true; // Already "terminated" + } + + // Other errors occurred + return false; +} + + +// On UNIX systems: just fork a new process. The command line will be executed from Fortran. +void process_create_posix(stdlib_pid* pid) +{ + + (*pid) = (stdlib_pid) fork(); +} + +#endif // _WIN32 + +///////////////////////////////////////////////////////////////////////////////////// +// Cross-platform interface +///////////////////////////////////////////////////////////////////////////////////// + +// Create or fork process +void process_create(const char* cmd, const char* stdin_stream, const char* stdin_file, + const char* stdout_file, const char* stderr_file, + stdlib_pid* pid) { +#ifdef _WIN32 + process_create_windows(cmd, stdin_stream, stdin_file, stdout_file, stderr_file, pid); +#else + process_create_posix(pid); +#endif // _WIN32 +} + +// Cross-platform interface: query process state +void process_query_status(stdlib_pid pid, bool wait, bool* is_running, int* exit_code) +{ +#ifdef _WIN32 + process_query_status_windows(pid, wait, is_running, exit_code); +#else + process_query_status_unix (pid, wait, is_running, exit_code); +#endif // _WIN32 +} + +// Cross-platform interface: kill process by ID +bool process_kill(stdlib_pid pid) +{ +#ifdef _WIN32 + return process_kill_windows(pid); +#else + return process_kill_unix(pid); +#endif // _WIN32 +} + +// Cross-platform interface: sleep(seconds) +void process_wait(float seconds) +{ +#ifdef _WIN32 + DWORD dwMilliseconds = (DWORD) (seconds * 1000); + Sleep(dwMilliseconds); +#else + int ierr; + + unsigned int ms = (unsigned int) (seconds * 1000); + struct timespec ts_remaining = + { + ms / 1000, + (ms % 1000) * 1000000L + }; + + do + { + struct timespec ts_sleep = ts_remaining; + ierr = nanosleep(&ts_sleep, &ts_remaining); + } + while ((EINTR == errno) && (-1 == ierr)); + + if (ierr != 0){ + switch(errno){ + case EINTR: + fprintf(stderr, "nanosleep() interrupted\n"); + break; + case EINVAL: + fprintf(stderr, "nanosleep() bad milliseconds value\n"); + exit(EINVAL); + case EFAULT: + fprintf(stderr, "nanosleep() problem copying information to user space\n"); + exit(EFAULT); + case ENOSYS: + fprintf(stderr, "nanosleep() not supported on this system\n"); + exit(ENOSYS); + default: + fprintf(stderr, "nanosleep() error\n"); + exit(1); + } + } + +#endif // _WIN32 +} + +// Returns the cross-platform file path of the null device for the current operating system. +const char* process_null_device(int* len) +{ +#ifdef _WIN32 + (*len) = strlen("NUL"); + return "NUL"; +#else + (*len) = strlen("/dev/null"); + return "/dev/null"; +#endif +} + +// Returns a boolean flag if macro _WIN32 is defined +bool process_is_windows() +{ +#ifdef _WIN32 + return true; +#else + return false; +#endif // _WIN32 +} + diff --git a/test/system/CMakeLists.txt b/test/system/CMakeLists.txt index 3e8f0369f..7dcc8060b 100644 --- a/test/system/CMakeLists.txt +++ b/test/system/CMakeLists.txt @@ -1 +1,2 @@ ADDTEST(sleep) +ADDTEST(subprocess) diff --git a/test/system/test_subprocess.f90 b/test/system/test_subprocess.f90 new file mode 100644 index 000000000..248e9bb8e --- /dev/null +++ b/test/system/test_subprocess.f90 @@ -0,0 +1,147 @@ +module test_subprocess + use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test + use stdlib_system, only: process_type, run, runasync, is_running, wait, update, elapsed, is_windows, kill + + implicit none + +contains + + !> Collect all exported unit tests + subroutine collect_suite(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest('test_run_synchronous', test_run_synchronous), & + new_unittest('test_run_asynchronous', test_run_asynchronous), & + new_unittest('test_process_kill', test_process_kill), & + new_unittest('test_process_state', test_process_state) & + ] + end subroutine collect_suite + + !> Test running a synchronous process + subroutine test_run_synchronous(error) + type(error_type), allocatable, intent(out) :: error + type(process_type) :: process + character(len=*), parameter :: command = "echo Hello" + + process = run(command, want_stdout=.true.) + call check(error, process%completed) + if (allocated(error)) return + + call check(error, trim(process%stdout) == "Hello", "stdout=<"//trim(process%stdout)//">, expected ") + end subroutine test_run_synchronous + + !> Test running an asynchronous process + subroutine test_run_asynchronous(error) + type(error_type), allocatable, intent(out) :: error + type(process_type) :: process + logical :: running + + ! The closest possible to a cross-platform command that waits + if (is_windows()) then + process = runasync("ping -n 2 127.0.0.1") + else + process = runasync("ping -c 2 127.0.0.1") + endif + ! Should not be immediately completed + call check(error, .not. process%completed, "ping process should not complete immediately") + if (allocated(error)) return + + running = is_running(process) + call check(error, running, "ping process should still be running immediately after started") + if (allocated(error)) return + + call wait(process) + call check(error, process%completed, "process should be complete after `call wait`") + if (allocated(error)) return + + call check(error, elapsed(process)>1.0e-4, "There should be a non-zero elapsed time") + + end subroutine test_run_asynchronous + + !> Test killing an asynchronous process + subroutine test_process_kill(error) + type(error_type), allocatable, intent(out) :: error + type(process_type) :: process + logical :: running, success + + ! Start a long-running process asynchronously + if (is_windows()) then + process = runasync("ping -n 10 127.0.0.1") + else + process = runasync("ping -c 10 127.0.0.1") + endif + + ! Ensure the process starts running + call check(error, .not. process%completed, "Process should not be completed immediately after starting") + if (allocated(error)) return + + running = is_running(process) + call check(error, running, "Process should be running immediately after starting") + if (allocated(error)) return + + ! Kill the process + call kill(process, success) + call check(error, success, "Failed to kill the process") + if (allocated(error)) return + + ! Verify the process is no longer running + call check(error, .not. is_running(process), "Process should not be running after being killed") + if (allocated(error)) return + + ! Ensure process state updates correctly after killing + call check(error, process%completed, "Process should be marked as completed after being killed") + end subroutine test_process_kill + + !> Test updating and checking process state + subroutine test_process_state(error) + type(error_type), allocatable, intent(out) :: error + type(process_type) :: process + character(len=*), parameter :: command = "echo Testing" + + process = run(command, want_stdout=.true., want_stderr=.true.) + + call update(process) + call check(error, process%completed) + if (allocated(error)) return + + call check(error, process%exit_code == 0, "Check zero exit code") + if (allocated(error)) return + + call check(error, len_trim(process%stderr) == 0, "Check no stderr output") + if (allocated(error)) return + + call check(error, trim(process%stdout) == "Testing", "stdout=<"//trim(process%stdout)//">, expected ") + if (allocated(error)) return + end subroutine test_process_state + +end module test_subprocess + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_subprocess, only : collect_suite + + implicit none + + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("subprocess", collect_suite) & + ] + + 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