syscalls: Add utmpx procedures and data structure.
* guix/build/syscalls.scm (<utmpx-entry>): New record type. (%utmpx): New C struct. (login-type): New bits. (setutxent, endutxent, getutxent, utmpx-entries): New procedures.master
parent
57f068bec5
commit
150309726f
|
@ -25,6 +25,7 @@
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-9 gnu)
|
#:use-module (srfi srfi-9 gnu)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
|
#:use-module (srfi srfi-19)
|
||||||
#:use-module (ice-9 rdelim)
|
#:use-module (ice-9 rdelim)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
@ -126,7 +127,22 @@
|
||||||
window-size-x-pixels
|
window-size-x-pixels
|
||||||
window-size-y-pixels
|
window-size-y-pixels
|
||||||
terminal-window-size
|
terminal-window-size
|
||||||
terminal-columns))
|
terminal-columns
|
||||||
|
|
||||||
|
utmpx?
|
||||||
|
utmpx-login-type
|
||||||
|
utmpx-pid
|
||||||
|
utmpx-line
|
||||||
|
utmpx-id
|
||||||
|
utmpx-user
|
||||||
|
utmpx-host
|
||||||
|
utmpx-termination-status
|
||||||
|
utmpx-exit-status
|
||||||
|
utmpx-session-id
|
||||||
|
utmpx-time
|
||||||
|
utmpx-address
|
||||||
|
login-type
|
||||||
|
utmpx-entries))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -1487,4 +1503,99 @@ always a positive integer."
|
||||||
(fall-back)
|
(fall-back)
|
||||||
(apply throw args))))))
|
(apply throw args))))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; utmpx.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define-record-type <utmpx-entry>
|
||||||
|
(utmpx type pid line id user host termination exit
|
||||||
|
session time address)
|
||||||
|
utmpx?
|
||||||
|
(type utmpx-login-type) ;login-type
|
||||||
|
(pid utmpx-pid)
|
||||||
|
(line utmpx-line) ;device name
|
||||||
|
(id utmpx-id)
|
||||||
|
(user utmpx-user) ;user name
|
||||||
|
(host utmpx-host) ;host name | #f
|
||||||
|
(termination utmpx-termination-status)
|
||||||
|
(exit utmpx-exit-status)
|
||||||
|
(session utmpx-session-id) ;session ID, for windowing
|
||||||
|
(time utmpx-time) ;entry time
|
||||||
|
(address utmpx-address))
|
||||||
|
|
||||||
|
(define-c-struct %utmpx ;<utmpx.h>
|
||||||
|
sizeof-utmpx
|
||||||
|
(lambda (type pid line id user host termination exit session
|
||||||
|
seconds useconds address %reserved)
|
||||||
|
(utmpx type pid
|
||||||
|
(bytes->string line) id
|
||||||
|
(bytes->string user)
|
||||||
|
(bytes->string host) termination exit
|
||||||
|
session
|
||||||
|
(make-time time-utc (* 1000 useconds) seconds)
|
||||||
|
address))
|
||||||
|
read-utmpx
|
||||||
|
write-utmpx!
|
||||||
|
(type short)
|
||||||
|
(pid int)
|
||||||
|
(line (array uint8 32))
|
||||||
|
(id (array uint8 4))
|
||||||
|
(user (array uint8 32))
|
||||||
|
(host (array uint8 256))
|
||||||
|
(termination short)
|
||||||
|
(exit short)
|
||||||
|
(session int32)
|
||||||
|
(time-seconds int32)
|
||||||
|
(time-useconds int32)
|
||||||
|
(address-v6 (array int32 4))
|
||||||
|
(%reserved (array uint8 20)))
|
||||||
|
|
||||||
|
(define-bits login-type
|
||||||
|
%unused-login-type->symbols
|
||||||
|
(define EMPTY 0) ;No valid user accounting information.
|
||||||
|
(define RUN_LVL 1) ;The system's runlevel.
|
||||||
|
(define BOOT_TIME 2) ;Time of system boot.
|
||||||
|
(define NEW_TIME 3) ;Time after system clock changed.
|
||||||
|
(define OLD_TIME 4) ;Time when system clock changed.
|
||||||
|
|
||||||
|
(define INIT_PROCESS 5) ;Process spawned by the init process.
|
||||||
|
(define LOGIN_PROCESS 6) ;Session leader of a logged in user.
|
||||||
|
(define USER_PROCESS 7) ;Normal process.
|
||||||
|
(define DEAD_PROCESS 8) ;Terminated process.
|
||||||
|
|
||||||
|
(define ACCOUNTING 9)) ;System accounting.
|
||||||
|
|
||||||
|
(define setutxent
|
||||||
|
(let ((proc (syscall->procedure void "setutxent" '())))
|
||||||
|
(lambda ()
|
||||||
|
"Open the user accounting database."
|
||||||
|
(proc))))
|
||||||
|
|
||||||
|
(define endutxent
|
||||||
|
(let ((proc (syscall->procedure void "endutxent" '())))
|
||||||
|
(lambda ()
|
||||||
|
"Close the user accounting database."
|
||||||
|
(proc))))
|
||||||
|
|
||||||
|
(define getutxent
|
||||||
|
(let ((proc (syscall->procedure '* "getutxent" '())))
|
||||||
|
(lambda ()
|
||||||
|
"Return the next entry from the user accounting database."
|
||||||
|
(let ((ptr (proc)))
|
||||||
|
(if (null-pointer? ptr)
|
||||||
|
#f
|
||||||
|
(read-utmpx (pointer->bytevector ptr sizeof-utmpx)))))))
|
||||||
|
|
||||||
|
(define (utmpx-entries)
|
||||||
|
"Return the list of entries read from the user accounting database."
|
||||||
|
(setutxent)
|
||||||
|
(let loop ((entries '()))
|
||||||
|
(match (getutxent)
|
||||||
|
(#f
|
||||||
|
(endutxent)
|
||||||
|
(reverse entries))
|
||||||
|
((? utmpx? entry)
|
||||||
|
(loop (cons entry entries))))))
|
||||||
|
|
||||||
;;; syscalls.scm ends here
|
;;; syscalls.scm ends here
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;; Copyright © 2015 David Thompson <davet@gnu.org>
|
;;; Copyright © 2015 David Thompson <davet@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
|
@ -441,6 +441,17 @@
|
||||||
(> (terminal-columns (open-input-string "Join us now, share the software!"))
|
(> (terminal-columns (open-input-string "Join us now, share the software!"))
|
||||||
0))
|
0))
|
||||||
|
|
||||||
|
(test-assert "utmpx-entries"
|
||||||
|
(match (utmpx-entries)
|
||||||
|
(((? utmpx? entries) ...)
|
||||||
|
(every (lambda (entry)
|
||||||
|
(match (utmpx-user entry)
|
||||||
|
((? string?)
|
||||||
|
(> (utmpx-pid entry) 0))
|
||||||
|
(#f ;might be DEAD_PROCESS
|
||||||
|
#t)))
|
||||||
|
entries))))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
||||||
(false-if-exception (delete-file temp-file))
|
(false-if-exception (delete-file temp-file))
|
||||||
|
|
Loading…
Reference in New Issue