[shepherd] 03/03: support: ‘primitive-load*’ opens files with O_CLOEXEC.

[Ludovic Courtès]

civodul pushed a commit to branch main
in repository shepherd.

commit 79b8bd8af4d94d3451aa50688d5e1b6a29ea0d9b
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jan 5 00:38:39 2024 +0100

    support: ‘primitive-load*’ opens files with O_CLOEXEC.
    
    * modules/shepherd/support.scm (call-with-port) [!guile-3]: New procedure.
    (primitive-load*): Use it, and open FILE with O_CLOEXEC.
---
 modules/shepherd/support.scm | 24 ++++++++++++++++++------
 1 file changed, 18 insertions(+), 6 deletions(-)

diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 53f67f8..bf70f2d 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -22,6 +22,7 @@
 
 (define-module (shepherd support)
   #:use-module (shepherd config)
+  #:use-module (shepherd system)                 ;for 'O_CLOEXEC' on Guile 2.2
   #:autoload   (shepherd colors) (color-output? color colorize-string)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -477,17 +478,28 @@ which has essential bindings pulled in."
     (module-use! m (resolve-interface '(shepherd service)))
     m))
 
+(cond-expand
+ (guile-3 #t)
+ (else
+  ;; This is missing in Guile 2.2.
+  (define (call-with-port port proc)
+    (call-with-values
+        (lambda () (proc port))
+      (lambda vals
+        (close-port port)
+        (apply values vals))))))
+
 (define (primitive-load* file)
   ;; Like 'primitive-load', but in Scheme, so that it does not introduce a
   ;; continuation barrier that would prevent code in FILE from suspending.
-  (call-with-input-file file
+  (call-with-port (open file (logior O_CLOEXEC O_RDONLY))
     (lambda (port)
       (let loop ((result *unspecified*))
-       (match (read port)
-         ((? eof-object?)
-          result)
-         (exp
-          (loop (primitive-eval exp))))))))
+        (match (read port)
+          ((? eof-object?)
+           result)
+          (exp
+           (loop (primitive-eval exp))))))))
 
 (define (load-in-user-module file)
   "Load FILE in a fresh user module that has essential bindings pulled in."