getlogin in (liii os) and fix test

goldfish/liii/os.scm

@@ -17,7 +17,7 @@
 (define-library (liii os)
 (export
   os-call os-arch os-type os-windows? os-linux? os-macos? os-temp-dir
-  isdir mkdir rmdir getenv getcwd listdir access)
+  isdir mkdir rmdir getenv getcwd listdir access getlogin)
 (import (scheme process-context)
         (liii error))
 (begin
@@ -82,5 +82,10 @@
 (define (getcwd)
   (g_getcwd))
 
+(define (getlogin)
+  (if (os-windows?)
+      (getenv "USERNAME")
+      (g_getlogin)))
+
 ) ; end of begin
 ) ; end of define-library

src/goldfish.hpp

@@ -25,6 +25,7 @@
 #ifdef TB_CONFIG_OS_WINDOWS
 #include <io.h>
 #else
+#include <pwd.h>
 #include <unistd.h>
 #endif
 
@@ -276,11 +277,22 @@ f_access (s7_scheme* sc, s7_pointer args) {
 #ifdef TB_CONFIG_OS_WINDOWS
   bool ret= (_access (path_c, mode) == 0);
 #else
-  bool ret= (access (path_c, mode) == 0);
+  bool           ret= (access (path_c, mode) == 0);
 #endif
   return s7_make_boolean (sc, ret);
 }
 
+static s7_pointer
+f_getlogin (s7_scheme* sc, s7_pointer args) {
+#ifdef TB_CONFIG_OS_WINDOWS
+  return s7_make_boolean (sc, false);
+#else
+  uid_t          uid= getuid ();
+  struct passwd* pwd= getpwuid (uid);
+  return s7_make_string (sc, pwd->pw_name);
+#endif
+}
+
 inline void
 glue_liii_os (s7_scheme* sc) {
   s7_pointer cur_env= s7_curlet (sc);
@@ -303,6 +315,8 @@ glue_liii_os (s7_scheme* sc) {
   const char* d_getcwd     = "(g_getcwd) => string";
   const char* s_access     = "g_access";
   const char* d_access     = "(g_access string integer) => boolean";
+  const char* s_getlogin   = "g_getlogin";
+  const char* d_getlogin   = "(g_getlogin) => string";
 
   s7_define (sc, cur_env, s7_make_symbol (sc, s_os_type),
              s7_make_typed_function (sc, s_os_type, f_os_type, 0, 0, false,
@@ -331,6 +345,9 @@ glue_liii_os (s7_scheme* sc) {
   s7_define (sc, cur_env, s7_make_symbol (sc, s_access),
              s7_make_typed_function (sc, s_access, f_access, 2, 0, false,
                                      d_access, NULL));
+  s7_define (sc, cur_env, s7_make_symbol (sc, s_getlogin),
+             s7_make_typed_function (sc, s_getlogin, f_getlogin, 0, 0, false,
+                                     d_access, NULL));
 }
 
 static s7_pointer

tests/scheme/boot-test.scm

@@ -14,8 +14,7 @@
 ; under the License.
 ;
 
-(import (srfi srfi-78)
-        (srfi srfi-1)
+(import (liii list)
         (liii check)
         (liii os))
 
@@ -25,13 +24,13 @@
   (check (file-exists? "/tmp") => #t)
   (check (file-exists? "/not_exists") => #f))
 
-(when (and (os-linux?) (not (string=? "/root" (getenv "HOME"))))
+(when (and (os-linux?) (not (string=? "root" (getlogin))))
   (check-catch 'permission-error (lambda () (file-exists? "/root"))))
 
 (when (os-windows?)
   (check (file-exists? "C:") => #t))
 
-(when (and (os-linux?) (not (string=? "/root" (getenv "HOME"))))
+(when (and (os-linux?) (not (string=? "root" (getlogin))))
   (check-catch 'permission-error (lambda () (delete-file "/root"))))
 
 (when (not (os-windows?))
@@ -42,5 +41,4 @@
   (delete-file "/tmp/test_delete_file")
   (check (file-exists? "/tmp/test_delete_file") => #f))
 
-(check-report)
-(if (check-failed?) (exit -1))
+(check-report "\n\nCheck report of boot-test.scm => ")