fortsh Public

Watch 0 Fork 0 Star 0
Fortran · 11758 bytes Raw Blame History
1 ! ==============================================================================
2 ! Module: coprocess
3 ! Purpose: Coprocess management for bidirectional communication
4 ! ==============================================================================
5 module coprocess
6 use shell_types
7 use system_interface
8 use iso_c_binding, only: c_int
9 use iso_fortran_env, only: output_unit, error_unit
10 implicit none
11 private :: kill_c ! Make kill_c private to avoid conflicts
12
13 ! Coprocess type
14 type :: coproc_t
15 character(len=256) :: name = ''
16 character(len=:), allocatable :: command
17 integer(c_pid_t) :: pid = 0
18 integer :: read_fd = -1 ! Shell reads from coprocess
19 integer :: write_fd = -1 ! Shell writes to coprocess
20 logical :: active = .false.
21 logical :: eof_reached = .false.
22 end type coproc_t
23
24 ! Global coprocess registry
25 type(coproc_t), save :: coprocs(10)
26 integer, save :: num_coprocs = 0
27
28 interface
29 function pipe_c(fds) bind(C, name="pipe")
30 import :: c_int
31 integer(c_int) :: pipe_c
32 integer(c_int), intent(out) :: fds(2)
33 end function
34
35 function fork_c() bind(C, name="fork") result(pid)
36 import :: c_pid_t
37 integer(c_pid_t) :: pid
38 end function
39
40 function dup2_c(oldfd, newfd) bind(C, name="dup2") result(ret)
41 import :: c_int
42 integer(c_int), value :: oldfd, newfd
43 integer(c_int) :: ret
44 end function
45
46 function close_c(fd) bind(C, name="close") result(ret)
47 import :: c_int
48 integer(c_int), value :: fd
49 integer(c_int) :: ret
50 end function
51
52 function waitpid_c(pid, status, options) bind(C, name="waitpid") result(ret)
53 import :: c_pid_t, c_int
54 integer(c_pid_t), value :: pid
55 integer(c_int), intent(out) :: status
56 integer(c_int), value :: options
57 integer(c_pid_t) :: ret
58 end function
59
60 function read_c(fd, buf, count) bind(C, name="read") result(bytes_read)
61 import :: c_int, c_ptr, c_size_t
62 integer(c_int), value :: fd
63 type(c_ptr), value :: buf
64 integer(c_size_t), value :: count
65 integer(c_size_t) :: bytes_read
66 end function
67
68 function write_c(fd, buf, count) bind(C, name="write") result(bytes_written)
69 import :: c_int, c_ptr, c_size_t
70 integer(c_int), value :: fd
71 type(c_ptr), value :: buf
72 integer(c_size_t), value :: count
73 integer(c_size_t) :: bytes_written
74 end function
75
76 function kill_c(pid, sig) bind(C, name="kill") result(ret)
77 import :: c_pid_t, c_int
78 integer(c_pid_t), value :: pid
79 integer(c_int), value :: sig
80 integer(c_int) :: ret
81 end function
82
83 function execlp_c(file, arg) bind(C, name="execlp")
84 import :: c_int, c_ptr
85 type(c_ptr), value :: file
86 type(c_ptr), value :: arg
87 integer(c_int) :: execlp_c
88 end function
89 end interface
90
91 ! C system() binding (avoid duplicate - use from system_interface if available)
92 interface
93 function system_c(command) bind(C, name="system")
94 import :: c_int, c_char
95 character(kind=c_char), intent(in) :: command(*)
96 integer(c_int) :: system_c
97 end function
98 end interface
99
100 integer, parameter :: SIGTERM = 15
101 integer, parameter :: SIGKILL = 9
102
103 contains
104
105 subroutine init_coprocess_registry()
106 integer :: i
107 do i = 1, size(coprocs)
108 coprocs(i)%command = ''
109 end do
110 end subroutine
111
112 ! Start a coprocess with optional name
113 function start_coprocess(command, name, interactive) result(coproc_id)
114 character(len=*), intent(in) :: command
115 character(len=*), intent(in), optional :: name
116 logical, intent(in), optional :: interactive
117 integer :: coproc_id
118
119 integer(c_int) :: pipe_to_child(2), pipe_from_child(2)
120 integer(c_pid_t) :: pid
121 integer :: i, ret
122 character(len=256) :: coproc_name
123
124 coproc_id = -1
125
126 ! Find available slot
127 do i = 1, size(coprocs)
128 if (.not. coprocs(i)%active) then
129 coproc_id = i
130 exit
131 end if
132 end do
133
134 if (coproc_id == -1) then
135 write(error_unit, '(a)') 'coprocess: maximum number of coprocesses reached'
136 return
137 end if
138
139 ! Create pipes
140 ret = pipe_c(pipe_to_child)
141 if (ret /= 0) then
142 write(error_unit, '(a)') 'coprocess: failed to create pipe to child'
143 return
144 end if
145
146 ret = pipe_c(pipe_from_child)
147 if (ret /= 0) then
148 write(error_unit, '(a)') 'coprocess: failed to create pipe from child'
149 ret = close_c(pipe_to_child(1))
150 ret = close_c(pipe_to_child(2))
151 return
152 end if
153
154 ! Fork process
155 pid = fork_c()
156
157 if (pid == 0) then
158 ! Child process
159
160 ! Redirect stdin to read from parent
161 ret = dup2_c(pipe_to_child(1), 0)
162 ret = close_c(pipe_to_child(1))
163 ret = close_c(pipe_to_child(2))
164
165 ! Redirect stdout to write to parent
166 ret = dup2_c(pipe_from_child(2), 1)
167 ret = close_c(pipe_from_child(1))
168 ret = close_c(pipe_from_child(2))
169
170 ! Execute command using shell
171 call execute_command_in_shell(command)
172
173 else if (pid > 0) then
174 ! Parent process
175
176 ! Close child ends of pipes
177 ret = close_c(pipe_to_child(1))
178 ret = close_c(pipe_from_child(2))
179
180 ! Set up coprocess structure
181 if (present(name)) then
182 coproc_name = name
183 else
184 write(coproc_name, '(a,I0)') 'COPROC', coproc_id
185 end if
186
187 coprocs(coproc_id)%name = coproc_name
188 coprocs(coproc_id)%command = command
189 coprocs(coproc_id)%pid = pid
190 coprocs(coproc_id)%write_fd = pipe_to_child(2) ! Shell writes here
191 coprocs(coproc_id)%read_fd = pipe_from_child(1) ! Shell reads here
192 coprocs(coproc_id)%active = .true.
193 coprocs(coproc_id)%eof_reached = .false.
194
195 num_coprocs = max(num_coprocs, coproc_id)
196
197 if (present(interactive) .and. interactive) then
198 write(error_unit, '(a,a,a,I0)') '[', trim(coproc_name), '] ', pid
199 end if
200
201 else
202 ! Fork failed
203 write(error_unit, '(a)') 'coprocess: fork failed'
204 ret = close_c(pipe_to_child(1))
205 ret = close_c(pipe_to_child(2))
206 ret = close_c(pipe_from_child(1))
207 ret = close_c(pipe_from_child(2))
208 coproc_id = -1
209 end if
210 end function
211
212 ! Write to coprocess
213 function write_to_coprocess(coproc_id, data) result(success)
214 integer, intent(in) :: coproc_id
215 character(len=*), intent(in) :: data
216 logical :: success
217
218 character(kind=c_char), target :: c_data(len(data)+1)
219 integer(c_size_t) :: bytes_written
220 integer :: i
221
222 success = .false.
223
224 if (coproc_id < 1 .or. coproc_id > size(coprocs)) return
225 if (.not. coprocs(coproc_id)%active) return
226 if (coprocs(coproc_id)%write_fd < 0) return
227
228 ! Convert to C string
229 do i = 1, len(data)
230 c_data(i) = data(i:i)
231 end do
232 c_data(len(data)+1) = c_null_char
233
234 ! Write to coprocess stdin
235 bytes_written = write_c(coprocs(coproc_id)%write_fd, c_loc(c_data), int(len(data), c_size_t))
236
237 if (bytes_written > 0) then
238 success = .true.
239 else
240 write(error_unit, '(a,a)') 'coprocess: write failed to ', trim(coprocs(coproc_id)%name)
241 end if
242 end function
243
244 ! Read from coprocess
245 function read_from_coprocess(coproc_id, timeout_ms) result(data)
246 integer, intent(in) :: coproc_id
247 integer, intent(in), optional :: timeout_ms
248 character(len=4096) :: data
249
250 character(kind=c_char), target :: c_buffer(4096)
251 integer(c_size_t) :: bytes_read
252 integer :: i
253
254 data = ''
255 if (.false. .and. present(timeout_ms)) print *, timeout_ms ! Silence unused warning
256
257 if (coproc_id < 1 .or. coproc_id > size(coprocs)) return
258 if (.not. coprocs(coproc_id)%active) return
259 if (coprocs(coproc_id)%eof_reached) return
260 if (coprocs(coproc_id)%read_fd < 0) return
261
262 ! Read from coprocess stdout
263 bytes_read = read_c(coprocs(coproc_id)%read_fd, c_loc(c_buffer), int(4096, c_size_t))
264
265 if (bytes_read > 0) then
266 ! Convert C buffer to Fortran string
267 do i = 1, int(bytes_read)
268 data(i:i) = c_buffer(i)
269 end do
270 else if (bytes_read == 0) then
271 ! EOF reached
272 coprocs(coproc_id)%eof_reached = .true.
273 else
274 ! Read error
275 write(error_unit, '(a,a)') 'coprocess: read failed from ', trim(coprocs(coproc_id)%name)
276 end if
277 end function
278
279 ! Find coprocess by name
280 function find_coprocess(name) result(coproc_id)
281 character(len=*), intent(in) :: name
282 integer :: coproc_id
283 integer :: i
284
285 coproc_id = -1
286
287 do i = 1, num_coprocs
288 if (coprocs(i)%active .and. trim(coprocs(i)%name) == trim(name)) then
289 coproc_id = i
290 exit
291 end if
292 end do
293 end function
294
295 ! Kill and cleanup coprocess
296 subroutine kill_coprocess(coproc_id)
297 integer, intent(in) :: coproc_id
298
299 integer :: ret, status
300
301 if (coproc_id < 1 .or. coproc_id > size(coprocs)) return
302 if (.not. coprocs(coproc_id)%active) return
303
304 ! Close file descriptors
305 if (coprocs(coproc_id)%read_fd >= 0) then
306 ret = close_c(coprocs(coproc_id)%read_fd)
307 end if
308
309 if (coprocs(coproc_id)%write_fd >= 0) then
310 ret = close_c(coprocs(coproc_id)%write_fd)
311 end if
312
313 ! Kill process if still running
314 if (coprocs(coproc_id)%pid > 0) then
315 ! Try SIGTERM first (graceful)
316 ret = kill_c(coprocs(coproc_id)%pid, SIGTERM)
317 ! Wait briefly and check if process is still alive
318 ret = waitpid_c(coprocs(coproc_id)%pid, status, 1) ! WNOHANG = 1
319 if (ret == 0) then
320 ! Process still running, force kill
321 ret = kill_c(coprocs(coproc_id)%pid, SIGKILL)
322 ret = waitpid_c(coprocs(coproc_id)%pid, status, 0)
323 end if
324 end if
325
326 ! Mark as inactive
327 coprocs(coproc_id)%active = .false.
328 coprocs(coproc_id)%name = ''
329 coprocs(coproc_id)%command = ''
330 coprocs(coproc_id)%pid = 0
331 coprocs(coproc_id)%read_fd = -1
332 coprocs(coproc_id)%write_fd = -1
333 coprocs(coproc_id)%eof_reached = .false.
334 end subroutine
335
336 ! List active coprocesses
337 subroutine list_coprocesses()
338 integer :: i
339 logical :: found_any
340
341 found_any = .false.
342
343 do i = 1, num_coprocs
344 if (coprocs(i)%active) then
345 if (.not. found_any) then
346 write(output_unit, '(a)') 'Active coprocesses:'
347 found_any = .true.
348 end if
349 write(output_unit, '(a,I2,a,a,a,I0,a,a)') '[', i, '] ', &
350 trim(coprocs(i)%name), ' PID:', coprocs(i)%pid, ' CMD: ', trim(coprocs(i)%command)
351 end if
352 end do
353
354 if (.not. found_any) then
355 write(output_unit, '(a)') 'No active coprocesses'
356 end if
357 end subroutine
358
359 ! Cleanup all coprocesses
360 subroutine cleanup_all_coprocesses()
361 integer :: i
362
363 do i = 1, num_coprocs
364 if (coprocs(i)%active) then
365 call kill_coprocess(i)
366 end if
367 end do
368
369 num_coprocs = 0
370 end subroutine
371
372 function int_to_string(val) result(str)
373 integer, intent(in) :: val
374 character(len=32) :: str
375
376 write(str, '(I0)') val
377 end function
378
379 subroutine execute_command_in_shell(command)
380 character(len=*), intent(in) :: command
381
382 character(kind=c_char), target :: c_command(len(command)+1)
383 integer(c_int) :: exit_status
384 integer :: i
385
386 ! Convert command to C string
387 do i = 1, len(command)
388 c_command(i) = command(i:i)
389 end do
390 c_command(len(command)+1) = c_null_char
391
392 ! Execute command using system()
393 ! This runs the command in a subshell (via /bin/sh -c)
394 exit_status = system_c(c_command)
395
396 ! Exit with the command's exit status (use c_exit from iso_c_binding)
397 call c_exit(int(exit_status / 256, c_int)) ! Extract exit code from wait status
398 end subroutine
399
400 end module coprocess