guix-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

01/01: build: syscalls: Add clone.


From: David Thompson
Subject: 01/01: build: syscalls: Add clone.
Date: Wed, 08 Jul 2015 00:41:36 +0000

davexunit pushed a commit to branch master
in repository guix.

commit 8950ed11c6a0d51be056b3509f3ab269787696e9
Author: David Thompson <address@hidden>
Date:   Sun May 31 20:26:47 2015 -0400

    build: syscalls: Add clone.
    
    * guix/build/syscalls.scm (clone): New procedure.
      (CLONE_NEWNS, CLONE_NEWUTS, CLONE_NEWIPC, CLONE_NEWUSER, CLONE_NEWPID,
      CLONE_NEWNET): New variables.
    * tests/syscalls.scm ("clone"): New test.
---
 guix/build/syscalls.scm |   33 +++++++++++++++++++++++++++++++++
 tests/syscalls.scm      |   15 +++++++++++++++
 2 files changed, 48 insertions(+), 0 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index a464040..cff0106 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -47,6 +47,14 @@
             processes
             mkdtemp!
 
+            CLONE_NEWNS
+            CLONE_NEWUTS
+            CLONE_NEWIPC
+            CLONE_NEWUSER
+            CLONE_NEWPID
+            CLONE_NEWNET
+            clone
+
             IFF_UP
             IFF_BROADCAST
             IFF_LOOPBACK
@@ -280,6 +288,31 @@ string TMPL and return its file name.  TMPL must end with 
'XXXXXX'."
                  (list err)))
         (pointer->string result)))))
 
+;; Linux clone flags, from linux/sched.h
+(define CLONE_NEWNS   #x00020000)
+(define CLONE_NEWUTS  #x04000000)
+(define CLONE_NEWIPC  #x08000000)
+(define CLONE_NEWUSER #x10000000)
+(define CLONE_NEWPID  #x20000000)
+(define CLONE_NEWNET  #x40000000)
+
+;; The libc interface to sys_clone is not useful for Scheme programs, so the
+;; low-level system call is wrapped instead.
+(define clone
+  (let* ((ptr        (dynamic-func "syscall" (dynamic-link)))
+         (proc       (pointer->procedure int ptr (list int int '*)))
+         ;; TODO: Don't do this.
+         (syscall-id (match (utsname:machine (uname))
+                       ("i686"   120)
+                       ("x86_64" 56)
+                       ("mips64" 5055)
+                       ("armv7l" 120))))
+    (lambda (flags)
+      "Create a new child process by duplicating the current parent process.
+Unlike the fork system call, clone accepts FLAGS that specify which resources
+are shared between the parent and child processes."
+      (proc syscall-id flags %null-pointer))))
+
 
 ;;;
 ;;; Packed structures.
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 049ca93..4bc6f03 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -76,6 +76,21 @@
            (rmdir dir)
            #t))))
 
+(define (user-namespace pid)
+  (string-append "/proc/" (number->string pid) "/ns/user"))
+
+(test-assert "clone"
+  (match (clone (logior CLONE_NEWUSER SIGCHLD))
+    (0 (primitive-exit 42))
+    (pid
+     ;; Check if user namespaces are different.
+     (and (not (equal? (readlink (user-namespace pid))
+                       (readlink (user-namespace (getpid)))))
+          (match (waitpid pid)
+            ((_ . status)
+             (= 42 (status:exit-val status))))))))
+
+
 (test-assert "all-network-interfaces"
   (match (all-network-interfaces)
     (((? string? names) ..1)



reply via email to

[Prev in Thread] Current Thread [Next in Thread]