| 1 |
program test_devloop_process |
| 2 |
use fgof_devloop, only : & |
| 3 |
FGOF_DEVLOOP_COMMAND_BUILD, & |
| 4 |
FGOF_DEVLOOP_COMMAND_SMOKE, & |
| 5 |
FGOF_DEVLOOP_DECISION_IDLE, & |
| 6 |
FGOF_DEVLOOP_DECISION_RESTART, & |
| 7 |
FGOF_DEVLOOP_DECISION_STOP, & |
| 8 |
clear_devloop_options, & |
| 9 |
devloop_build_command, & |
| 10 |
devloop_manual_trigger, & |
| 11 |
devloop_run_command, & |
| 12 |
devloop_smoke_command, & |
| 13 |
devloop_start_trigger, & |
| 14 |
run_devloop_cycle, & |
| 15 |
start_devloop |
| 16 |
use fgof_devloop_types, only : & |
| 17 |
devloop_command_spec, & |
| 18 |
devloop_options, & |
| 19 |
devloop_state, & |
| 20 |
devloop_supervision_result |
| 21 |
use fgof_process, only : & |
| 22 |
FGOF_PROCESS_ERR_TIMEOUT, & |
| 23 |
process_options, & |
| 24 |
shell |
| 25 |
implicit none |
| 26 |
|
| 27 |
call test_successful_build_command() |
| 28 |
call test_build_failure_skips_later_commands() |
| 29 |
call test_timeout_uses_failure_policy() |
| 30 |
|
| 31 |
contains |
| 32 |
|
| 33 |
subroutine test_successful_build_command() |
| 34 |
type(devloop_state) :: state |
| 35 |
type(devloop_command_spec) :: build |
| 36 |
type(devloop_supervision_result) :: supervision |
| 37 |
type(process_options) :: process_config |
| 38 |
|
| 39 |
process_config = process_options() |
| 40 |
process_config%capture_stdout = .true. |
| 41 |
|
| 42 |
call start_devloop(state) |
| 43 |
build = devloop_build_command(shell("printf build"), process_config, "compile") |
| 44 |
supervision = run_devloop_cycle(state, devloop_start_trigger(), build_command=build) |
| 45 |
|
| 46 |
if (.not. supervision%started) error stop "process supervision should start a cycle" |
| 47 |
if (.not. supervision%succeeded) error stop "successful process should succeed" |
| 48 |
if (supervision%failed) error stop "successful process should not fail" |
| 49 |
if (supervision%command_count /= 1) error stop "one build command should run" |
| 50 |
if (supervision%build%kind /= FGOF_DEVLOOP_COMMAND_BUILD) error stop "build kind should be preserved" |
| 51 |
if (.not. supervision%build%requested) error stop "build command should be requested" |
| 52 |
if (.not. supervision%build%succeeded) error stop "build command should succeed" |
| 53 |
if (supervision%build%label /= "compile") error stop "custom build label should be preserved" |
| 54 |
if (supervision%build%process%stdout /= "build") error stop "build stdout should stay visible" |
| 55 |
if (supervision%decision%kind /= FGOF_DEVLOOP_DECISION_IDLE) error stop "success should idle" |
| 56 |
if (state%running) error stop "finished process cycle should not leave state running" |
| 57 |
end subroutine test_successful_build_command |
| 58 |
|
| 59 |
subroutine test_build_failure_skips_later_commands() |
| 60 |
type(devloop_state) :: state |
| 61 |
type(devloop_command_spec) :: build |
| 62 |
type(devloop_command_spec) :: run_spec |
| 63 |
type(devloop_supervision_result) :: supervision |
| 64 |
|
| 65 |
call start_devloop(state) |
| 66 |
build = devloop_build_command(shell("exit 7")) |
| 67 |
run_spec = devloop_run_command(shell("exit 0")) |
| 68 |
supervision = run_devloop_cycle(state, devloop_manual_trigger("manual"), & |
| 69 |
build_command=build, run_command=run_spec) |
| 70 |
|
| 71 |
if (.not. supervision%failed) error stop "failed build should fail supervision" |
| 72 |
if (supervision%succeeded) error stop "failed build should not succeed" |
| 73 |
if (supervision%command_count /= 1) error stop "run command should be skipped after build failure" |
| 74 |
if (supervision%failed_command_kind /= FGOF_DEVLOOP_COMMAND_BUILD) then |
| 75 |
error stop "failed command kind should identify build" |
| 76 |
end if |
| 77 |
if (supervision%last_exit_code /= 7) error stop "failed exit code should be preserved" |
| 78 |
if (supervision%build%exit_code /= 7) error stop "build exit code should be preserved" |
| 79 |
if (supervision%run%requested) error stop "run command should not execute after build failure" |
| 80 |
if (.not. supervision%run%skipped) error stop "skipped run command should stay marked skipped" |
| 81 |
if (supervision%decision%kind /= FGOF_DEVLOOP_DECISION_RESTART) error stop "failure should request restart" |
| 82 |
if (.not. supervision%decision%should_run) error stop "restart decision should be runnable" |
| 83 |
if (state%consecutive_failures /= 1) error stop "failure count should advance" |
| 84 |
end subroutine test_build_failure_skips_later_commands |
| 85 |
|
| 86 |
subroutine test_timeout_uses_failure_policy() |
| 87 |
type(devloop_state) :: state |
| 88 |
type(devloop_options) :: loop_options |
| 89 |
type(devloop_command_spec) :: smoke |
| 90 |
type(devloop_supervision_result) :: supervision |
| 91 |
type(process_options) :: process_config |
| 92 |
|
| 93 |
loop_options = clear_devloop_options() |
| 94 |
loop_options%stop_on_failure = .true. |
| 95 |
process_config = process_options() |
| 96 |
process_config%timeout_ms = 100 |
| 97 |
|
| 98 |
call start_devloop(state, loop_options) |
| 99 |
smoke = devloop_smoke_command(shell("sleep 1"), process_config) |
| 100 |
supervision = run_devloop_cycle(state, devloop_manual_trigger("timeout"), smoke_command=smoke) |
| 101 |
|
| 102 |
if (.not. supervision%failed) error stop "timed-out smoke should fail supervision" |
| 103 |
if (.not. supervision%timed_out) error stop "timeout should be visible on supervision" |
| 104 |
if (supervision%failed_command_kind /= FGOF_DEVLOOP_COMMAND_SMOKE) then |
| 105 |
error stop "failed command kind should identify smoke" |
| 106 |
end if |
| 107 |
if (supervision%process_error_code /= FGOF_PROCESS_ERR_TIMEOUT) then |
| 108 |
error stop "timeout should preserve process error code" |
| 109 |
end if |
| 110 |
if (.not. supervision%smoke%timed_out) error stop "smoke result should preserve timeout" |
| 111 |
if (supervision%decision%kind /= FGOF_DEVLOOP_DECISION_STOP) error stop "stop policy should stop" |
| 112 |
if (.not. state%stopped) error stop "stop policy should mark state stopped" |
| 113 |
end subroutine test_timeout_uses_failure_policy |
| 114 |
|
| 115 |
end program test_devloop_process |
| 116 |
|