syscalls: Add 'thread-name' and 'set-thread-name'.

* guix/build/syscalls.scm (PR_SET_NAME, PR_GET_NAME)
(%max-thread-name-length): New variables.
(%prctl, set-thread-name, thread-name): New procedures.
* tests/syscalls.scm ("set-thread-name"): New test.
This commit is contained in:
Ludovic Courtès 2017-05-28 15:49:11 +02:00
parent 2b95f24721
commit aa401f9ba6
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 57 additions and 0 deletions

View file

@ -69,6 +69,9 @@ (define-module (guix build syscalls)
pivot-root
fcntl-flock
set-thread-name
thread-name
CLONE_CHILD_CLEARTID
CLONE_CHILD_SETTID
CLONE_NEWNS
@ -882,6 +885,52 @@ (define bv
;; Presumably we got EAGAIN or so.
(throw 'flock-error err))))))
;;;
;;; Miscellaneous, aka. 'prctl'.
;;;
(define %prctl
;; Should it win the API contest against 'ioctl'? You tell us!
(syscall->procedure int "prctl"
(list int unsigned-long unsigned-long
unsigned-long unsigned-long)))
(define PR_SET_NAME 15) ;<linux/prctl.h>
(define PR_GET_NAME 16)
(define %max-thread-name-length
;; Maximum length in bytes of the process name, including the terminating
;; zero.
16)
(define (set-thread-name name)
"Set the name of the calling thread to NAME. NAME is truncated to 15
bytes."
(let ((ptr (string->pointer name)))
(let-values (((ret err)
(%prctl PR_SET_NAME
(pointer-address ptr) 0 0 0)))
(unless (zero? ret)
(throw 'set-process-name "set-process-name"
"set-process-name: ~A"
(list (strerror err))
(list err))))))
(define (thread-name)
"Return the name of the calling thread as a string."
(let ((buf (make-bytevector %max-thread-name-length)))
(let-values (((ret err)
(%prctl PR_GET_NAME
(pointer-address (bytevector->pointer buf))
0 0 0)))
(if (zero? ret)
(bytes->string (bytevector->u8-list buf))
(throw 'process-name "process-name"
"process-name: ~A"
(list (strerror err))
(list err))))))
;;;
;;; Network interfaces.

View file

@ -266,6 +266,14 @@ (define perform-container-tests?
(close-port file)
result)))))))))
(test-equal "set-thread-name"
"Syscall Test"
(let ((name (thread-name)))
(set-thread-name "Syscall Test")
(let ((new-name (thread-name)))
(set-thread-name name)
new-name)))
(test-assert "all-network-interface-names"
(match (all-network-interface-names)
(((? string? names) ..1)