Hey! I took the liberty to extend this patch a bit more, some windows stuff had been left out.
Also, according to the documentation, current-process-id should be in (chicken process-context) so I’ve put it there and changed types.db accordingly. Finally, the create-session symbol is currently in (chicken process-context posix) but the documentation says it should be in (chicken process). I think it makes more sense the way it is so we should update the documentation. I leave the final decision to the commiter.
>From a045d44db41054b9c25c15dedc24627627401a78 Mon Sep 17 00:00:00 2001 From: Kristian Lein-Mathisen <[email protected]> Date: Thu, 3 May 2018 14:52:20 +0200 Subject: [PATCH] Fixes namespaces of chicken.process-context.posix exports These identifiers were exporting undefined values. Note that the lambda-info of these procedures are now incorrectly missing the namespace prefix. Let's address in a separate commit. Signed-off-by: Kooda <[email protected]> --- library.scm | 6 +++- posix-common.scm | 2 -- posix.scm | 3 +- posixunix.scm | 74 ++++++++++++++++++++++++++---------------------- posixwin.scm | 14 +++++---- types.db | 2 +- 6 files changed, 55 insertions(+), 46 deletions(-) diff --git a/library.scm b/library.scm index d05d85c2..47648ea3 100644 --- a/library.scm +++ b/library.scm @@ -5930,7 +5930,8 @@ static C_word C_fcall C_setenv(C_word x, C_word y) { program-name executable-pathname change-directory current-directory get-environment-variable get-environment-variables - set-environment-variable! unset-environment-variable!) + set-environment-variable! unset-environment-variable! + current-process-id) (import scheme) (import chicken.base chicken.fixnum chicken.foreign) @@ -6050,6 +6051,9 @@ static C_word C_fcall C_setenv(C_word x, C_word y) { (##sys#check-list x 'command-line-arguments) x) ) ) +(define current-process-id + (foreign-lambda int "C_getpid")) + ) ; chicken.process-context diff --git a/posix-common.scm b/posix-common.scm index ea8cf78d..6b22a54b 100644 --- a/posix-common.scm +++ b/posix-common.scm @@ -600,8 +600,6 @@ EOF ;;; Processes -(define current-process-id (foreign-lambda int "C_getpid")) - (set! chicken.process#process-sleep (lambda (n) (##sys#check-fixnum n 'process-sleep) diff --git a/posix.scm b/posix.scm index 6ef41dfb..ba14855d 100644 --- a/posix.scm +++ b/posix.scm @@ -320,7 +320,7 @@ (module chicken.process-context.posix (change-directory* set-root-directory! current-effective-group-id current-effective-user-id - current-group-id current-process-id current-user-id + current-group-id current-user-id parent-process-id current-user-name current-effective-user-name create-session process-group-id user-information) @@ -332,7 +332,6 @@ (define current-effective-group-id) (define current-effective-user-id) (define current-group-id) -(define current-process-id) (define current-user-id) (define parent-process-id) (define current-user-name) diff --git a/posixunix.scm b/posixunix.scm index 3fd30dbd..a4995598 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -606,7 +606,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; Getting group- and user-information: -(define current-user-id +(set! chicken.process-context.posix#current-user-id (getter-with-setter (foreign-lambda int "C_getuid") (lambda (id) @@ -615,7 +615,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (##sys#error 'current-user-id!-setter "cannot set user ID" id) ) ) "(current-user-id)")) -(define current-effective-user-id +(set! chicken.process-context.posix#current-effective-user-id (getter-with-setter (foreign-lambda int "C_geteuid") (lambda (id) @@ -625,7 +625,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) 'effective-user-id!-setter "cannot set effective user ID" id) ) ) "(current-effective-user-id)")) -(define current-group-id +(set! chicken.process-context.posix#current-group-id (getter-with-setter (foreign-lambda int "C_getgid") (lambda (id) @@ -634,7 +634,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (##sys#error 'current-group-id!-setter "cannot set group ID" id) ) ) "(current-group-id)") ) -(define current-effective-group-id +(set! chicken.process-context.posix#current-effective-group-id (getter-with-setter (foreign-lambda int "C_getegid") (lambda (id) @@ -652,27 +652,32 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (define-foreign-variable _user-dir c-string "C_user->pw_dir") (define-foreign-variable _user-shell c-string "C_user->pw_shell") -(define (user-information user #!optional as-vector) - (let ([r (if (fixnum? user) - (##core#inline "C_getpwuid" user) - (begin - (##sys#check-string user 'user-information) - (##core#inline "C_getpwnam" (##sys#make-c-string user 'user-information)) ) ) ] ) - (and r - ((if as-vector vector list) - _user-name - _user-passwd - _user-uid - _user-gid - _user-gecos - _user-dir - _user-shell) ) ) ) - -(define (current-user-name) - (car (user-information (current-user-id))) ) - -(define (current-effective-user-name) - (car (user-information (current-effective-user-id))) ) +(set! chicken.process-context.posix#user-information + (lambda (user #!optional as-vector) + (let ([r (if (fixnum? user) + (##core#inline "C_getpwuid" user) + (begin + (##sys#check-string user 'user-information) + (##core#inline "C_getpwnam" (##sys#make-c-string user 'user-information)) ) ) ] ) + (and r + ((if as-vector vector list) + _user-name + _user-passwd + _user-uid + _user-gid + _user-gecos + _user-dir + _user-shell) ) )) ) + +(set! chicken.process-context.posix#current-user-name + (lambda () + (car (chicken.process-context.posix#user-information + (chicken.process-context.posix#current-user-id)))) ) + +(set! chicken.process-context.posix#current-effective-user-name + (lambda () + (car (chicken.process-context.posix#user-information + (chicken.process-context.posix#current-effective-user-id)))) ) (define chown (lambda (loc f uid gid) @@ -692,14 +697,15 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (when (fx< r 0) (posix-error #:file-error loc "cannot change file owner" f uid gid) )) ) ) -(define (create-session) - (let ([a (##core#inline "C_setsid" #f)]) - (when (fx< a 0) - (##sys#update-errno) - (##sys#error 'create-session "cannot create session") ) - a) ) +(set! chicken.process-context.posix#create-session + (lambda () + (let ([a (##core#inline "C_setsid" #f)]) + (when (fx< a 0) + (##sys#update-errno) + (##sys#error 'create-session "cannot create session") ) + a)) ) -(define process-group-id +(set! chicken.process-context.posix#process-group-id (getter-with-setter (lambda (pid) (##sys#check-fixnum pid 'process-group-id) @@ -1120,7 +1126,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (##core#inline "C_WTERMSIG" _wait-status)) (else (##core#inline "C_WSTOPSIG" _wait-status)) ) )) ) ) -(define parent-process-id (foreign-lambda int "C_getppid")) +(set! chicken.process-context.posix#parent-process-id (foreign-lambda int "C_getppid")) (set! chicken.process#process-signal (lambda (id . sig) @@ -1276,7 +1282,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) ;;; chroot: -(define set-root-directory! +(set! chicken.process-context.posix#set-root-directory! (let ([chroot (foreign-lambda int "chroot" c-string)]) (lambda (dir) (##sys#check-string dir 'set-root-directory!) diff --git a/posixwin.scm b/posixwin.scm index fef66b8f..0879fcfa 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -863,12 +863,13 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (define-foreign-variable _username c-string "C_username") -(define (current-user-name) - (if (##core#inline "C_get_user_name") - _username - (begin - (##sys#update-errno) - (##sys#error 'current-user-name "cannot retrieve current user-name") ) ) ) +(set! chicken.process-context.posix#current-user-name + (lambda () + (if (##core#inline "C_get_user_name") + _username + (begin + (##sys#update-errno) + (##sys#error 'current-user-name "cannot retrieve current user-name") ) ) ) ;;; unimplemented stuff: @@ -882,6 +883,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime) (set!-unimplemented chicken.process-context.posix#current-effective-user-name) (set!-unimplemented chicken.process-context.posix#current-group-id) (set!-unimplemented chicken.process-context.posix#current-user-id) +(set!-unimplemented chicken.process-context.posix#user-information) (set!-unimplemented chicken.file.posix#file-control) (set!-unimplemented chicken.file.posix#file-link) (set!-unimplemented chicken.file.posix#file-lock) diff --git a/types.db b/types.db index c7f9910b..6ec5ad79 100644 --- a/types.db +++ b/types.db @@ -1922,6 +1922,7 @@ (chicken.process-context#program-name (#(procedure #:clean #:enforce) chicken.process-context#program-name (#!optional string) string)) (chicken.process-context#set-environment-variable! (#(procedure #:clean #:enforce) chicken.process-context#set-environment-variable! (string string) undefined)) (chicken.process-context#unset-environment-variable! (#(procedure #:clean #:enforce) chicken.process-context#unset-environment-variable! (string) undefined)) +(chicken.process-context#current-process-id (#(procedure #:clean) chicken.process-context#current-process-id () fixnum)) ;; process-context.posix @@ -1932,7 +1933,6 @@ (chicken.process-context.posix#current-effective-user-id (#(procedure #:clean) chicken.process-context.posix#current-effective-user-id () fixnum)) (chicken.process-context.posix#current-effective-user-name (#(procedure #:clean) chicken.process-context.posix#current-effective-user-name () string)) (chicken.process-context.posix#current-group-id (#(procedure #:clean) chicken.process-context.posix#current-group-id () fixnum)) -(chicken.process-context.posix#current-process-id (#(procedure #:clean) chicken.process-context.posix#current-process-id () fixnum)) (chicken.process-context.posix#current-user-id (#(procedure #:clean) chicken.process-context.posix#current-user-id () fixnum)) (chicken.process-context.posix#current-user-name (#(procedure #:clean) chicken.process-context.posix#current-user-name () string)) (chicken.process-context.posix#parent-process-id (#(procedure #:clean) chicken.process-context.posix#parent-process-id () fixnum)) -- 2.17.0
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
