Browse Source

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.
wip-git-https
Ludovic Courtès 5 years ago
parent
commit
150309726f
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 113
      guix/build/syscalls.scm
  2. 13
      tests/syscalls.scm

113
guix/build/syscalls.scm

@ -25,6 +25,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
@ -126,7 +127,22 @@
window-size-x-pixels
window-size-y-pixels
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:
;;;
@ -1487,4 +1503,99 @@ always a positive integer."
(fall-back)
(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

13
tests/syscalls.scm

@ -1,5 +1,5 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
@ -441,6 +441,17 @@
(> (terminal-columns (open-input-string "Join us now, share the software!"))
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)
(false-if-exception (delete-file temp-file))
Loading…
Cancel
Save