[shepherd] 05/10: system: Add 'pipe2' bindings.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 10c65fcf2b33dd3d20f5fe9fb9b31d5b4e66c644
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 7 15:31:09 2022 +0200

    system: Add 'pipe2' bindings.
    
    * modules/shepherd/system.scm.in (define-as-needed): New macro.
    (pipe2): New procedure.
---
 modules/shepherd/system.scm.in | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

diff --git a/modules/shepherd/system.scm.in b/modules/shepherd/system.scm.in
index 0978c18..48ca9db 100644
--- a/modules/shepherd/system.scm.in
+++ b/modules/shepherd/system.scm.in
@@ -33,6 +33,7 @@
             PR_SET_CHILD_SUBREAPER
             getpgid
             ipv6-only
+            pipe2
             SFD_CLOEXEC
             signalfd
             consume-signalfd-siginfo
@@ -152,6 +153,43 @@ only (by default, Linux binds AF_INET6 addresses on IPv4 
as well)."
   (setsockopt port @IPPROTO_IPV6@ @IPV6_V6ONLY@ 1)
   port)
 
+(define-syntax define-as-needed             ;copied from (guix build syscalls)
+  (syntax-rules ()
+    "Define VARIABLE.  If VARIABLE already exists in (guile) then re-export it,
+  otherwise export the newly-defined VARIABLE."
+    ((_ (proc args ...) body ...)
+     (define-as-needed proc (lambda* (args ...) body ...)))
+    ((_ variable value)
+     (if (module-defined? the-scm-module 'variable)
+         (module-re-export! (current-module) '(variable))
+         (begin
+           (module-define! (current-module) 'variable value)
+           (module-export! (current-module) '(variable)))))))
+
+(define-as-needed pipe2
+  ;; Use 'define-as-needed' in case Guile > 3.0.8 comes with a same-named
+  ;; binding.
+  (let ((proc (syscall->procedure int "pipe2" `(* ,int))))
+    (lambda* (#:optional (flags 0))
+      "Return a newly created pipe: a pair of ports linked together on the
+local machine.  The car is the input port, and the cdr is the output port.
+
+The difference compared to 'pipe' is that is the optional FLAGS argument."
+      (let* ((bv  (make-bytevector (* (sizeof int) 2)))
+             (ptr (bytevector->pointer bv)))
+        (let-values (((result err) (proc ptr flags)))
+          (if (zero? result)
+              (let ((in  (bytevector-sint-ref bv 0
+                                              (native-endianness)
+                                              (sizeof int)))
+                    (out (bytevector-sint-ref bv (sizeof int)
+                                              (native-endianness)
+                                              (sizeof int))))
+                (cons (fdopen in "r") (fdopen out "w")))
+              (throw 'system-error "pipe2" "~A"
+                     (list (strerror err))
+                     (list err))))))))
+
 (define (allocate-sigset)
   (bytevector->pointer (make-bytevector @SIZEOF_SIGSET_T@)))