home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / pruxenv.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  7KB  |  230 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pruxenv.c,v 1.19 2000/12/05 21:23:47 cph Exp $
  4.  
  5. Copyright (c) 1990-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Unix-specific process-environment primitives. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "ux.h"
  27.  
  28. #ifdef HAVE_SOCKETS
  29. #  include "uxsock.h"
  30. #endif
  31.  
  32. DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1,
  33.   "Convert a file system time stamp into a date/time string.")
  34. {
  35.   PRIMITIVE_HEADER (1);
  36.   CHECK_ARG (1, INTEGER_P);
  37.   {
  38.     time_t clock = (arg_integer (1));
  39.     char * time_string = (UX_ctime (&clock));
  40.     (time_string[24]) = '\0';
  41.     PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) time_string));
  42.   }
  43. }
  44.  
  45. DEFINE_PRIMITIVE ("GET-USER-HOME-DIRECTORY", Prim_get_user_home_directory, 1, 1,
  46.   "Return the file name of a given user's home directory.\n\
  47. The user name argument must be a string.\n\
  48. If no such user is known, #F is returned.")
  49. {
  50.   PRIMITIVE_HEADER (1);
  51.   {
  52.     struct passwd * entry = (UX_getpwnam (STRING_ARG (1)));
  53.     PRIMITIVE_RETURN
  54.       ((entry == 0) ? SHARP_F
  55.        : (char_pointer_to_string ((unsigned char *) (entry -> pw_dir))));
  56.   }
  57. }
  58.  
  59. DEFINE_PRIMITIVE ("UID->STRING", Prim_uid_to_string, 1, 1,
  60.   "Return the user name corresponding to UID.\n\
  61. If the argument is not a known user ID, #F is returned.")
  62. {
  63.   PRIMITIVE_HEADER (1);
  64.   {
  65.     struct passwd * entry = (UX_getpwuid (arg_nonnegative_integer (1)));
  66.     PRIMITIVE_RETURN
  67.       ((entry == 0) ? SHARP_F
  68.        : (char_pointer_to_string ((unsigned char *) (entry -> pw_name))));
  69.   }
  70. }
  71.  
  72. DEFINE_PRIMITIVE ("GID->STRING", Prim_gid_to_string, 1, 1,
  73.   "Return the group name corresponding to GID.\n\
  74. If the argument is not a known group ID, #F is returned.")
  75. {
  76.   PRIMITIVE_HEADER (1);
  77.   {
  78.     struct group * entry = (UX_getgrgid (arg_nonnegative_integer (1)));
  79.     PRIMITIVE_RETURN
  80.       ((entry == 0) ? SHARP_F
  81.        : (char_pointer_to_string ((unsigned char *) (entry -> gr_name))));
  82.   }
  83. }
  84.  
  85. DEFINE_PRIMITIVE ("CURRENT-PID", Prim_current_pid, 0, 0,
  86.   "Return Scheme's PID.")
  87. {
  88.   PRIMITIVE_HEADER (0);
  89.   PRIMITIVE_RETURN (long_to_integer (UX_getpid ()));
  90. }
  91.  
  92. DEFINE_PRIMITIVE ("CURRENT-UID", Prim_current_uid, 0, 0,
  93.   "Return Scheme's effective UID.")
  94. {
  95.   PRIMITIVE_HEADER (0);
  96.   PRIMITIVE_RETURN (long_to_integer (UX_geteuid ()));
  97. }
  98.  
  99. DEFINE_PRIMITIVE ("CURRENT-GID", Prim_current_gid, 0, 0,
  100.   "Return Scheme's effective GID.")
  101. {
  102.   PRIMITIVE_HEADER (0);
  103.   PRIMITIVE_RETURN (long_to_integer (UX_getegid ()));
  104. }
  105.  
  106. DEFINE_PRIMITIVE ("REAL-UID", Prim_real_uid, 0, 0,
  107.   "Return Scheme's real UID.")
  108. {
  109.   PRIMITIVE_HEADER (0);
  110.   PRIMITIVE_RETURN (long_to_integer (UX_getuid ()));
  111. }
  112.  
  113. DEFINE_PRIMITIVE ("REAL-GID", Prim_real_gid, 0, 0,
  114.   "Return Scheme's real GID.")
  115. {
  116.   PRIMITIVE_HEADER (0);
  117.   PRIMITIVE_RETURN (long_to_integer (UX_getgid ()));
  118. }
  119.  
  120. DEFINE_PRIMITIVE ("CURRENT-USER-NAME", Prim_current_user_name, 0, 0,
  121.   "Return (as a string) the user name of the user running Scheme.")
  122. {
  123.   extern CONST char * EXFUN (OS_current_user_name, (void));
  124.   PRIMITIVE_HEADER (0);
  125.   PRIMITIVE_RETURN (char_pointer_to_string
  126.             ((unsigned char *) OS_current_user_name ()));
  127. }
  128.  
  129. DEFINE_PRIMITIVE ("CURRENT-USER-HOME-DIRECTORY", Prim_current_user_home_directory, 0, 0,
  130.   "Return the name of the current user's home directory.")
  131. {
  132.   extern CONST char * EXFUN (OS_current_user_home_directory, (void));
  133.   PRIMITIVE_HEADER (0);
  134.   PRIMITIVE_RETURN
  135.     (char_pointer_to_string ((unsigned char *)
  136.                  OS_current_user_home_directory ()));
  137. }
  138.  
  139. DEFINE_PRIMITIVE ("SYSTEM", Prim_system, 1, 1,
  140.   "Invoke sh (the Bourne shell) on the string argument.\n\
  141. Wait until the shell terminates, returning its exit status as an integer.")
  142. {
  143.   PRIMITIVE_HEADER (1);
  144.   PRIMITIVE_RETURN (long_to_integer (UX_system (STRING_ARG (1))));
  145. }
  146.  
  147. DEFINE_PRIMITIVE ("GET-ENVIRONMENT-VARIABLE", Prim_get_environment_variable, 1, 1,
  148.   "Look up the value of a variable in the user's shell environment.\n\
  149. The argument, a variable name, must be a string.\n\
  150. The result is either a string (the variable's value),\n\
  151.  or #F indicating that the variable does not exist.")
  152. {
  153.   PRIMITIVE_HEADER (1);
  154.   {
  155.     CONST char * variable_value = (UX_getenv (STRING_ARG (1)));
  156.     PRIMITIVE_RETURN
  157.       ((variable_value == 0)
  158.        ? SHARP_F
  159.        : (char_pointer_to_string ((unsigned char *) variable_value)));
  160.   }
  161. }
  162.  
  163. #define HOSTNAMESIZE 1024
  164.  
  165. DEFINE_PRIMITIVE ("FULL-HOSTNAME", Prim_full_hostname, 0, 0,
  166.   "Returns the full hostname (including domain if available) as a string.")
  167. {
  168.   PRIMITIVE_HEADER (0);
  169.   {
  170.     char this_host_name [HOSTNAMESIZE];
  171. #ifdef HAVE_SOCKETS
  172.     struct hostent * EXFUN (gethostbyname, (CONST char *));
  173.     struct hostent * this_host_entry;
  174.  
  175.     STD_VOID_SYSTEM_CALL
  176.       (syscall_gethostname,
  177.        (UX_gethostname (this_host_name, HOSTNAMESIZE)));
  178. #else
  179.     strcpy (this_host_name, "unknown-host.unknown.unknown");
  180. #endif
  181.  
  182. #ifdef HAVE_SOCKETS
  183.     this_host_entry = (gethostbyname (this_host_name));
  184.     PRIMITIVE_RETURN
  185.       ((this_host_entry == 0)
  186.        ? SHARP_F
  187.        : (char_pointer_to_string
  188.       ((unsigned char *) (this_host_entry -> h_name))));
  189. #else
  190.     PRIMITIVE_RETURN
  191.       (char_pointer_to_string ((unsigned char *) this_host_name));
  192. #endif
  193.   }
  194. }
  195.  
  196. DEFINE_PRIMITIVE ("HOSTNAME", Prim_hostname, 0, 0,
  197.   "Returns the hostname of the machine as a string.")
  198. {
  199.   PRIMITIVE_HEADER (0);
  200.   {
  201.     char this_host_name[HOSTNAMESIZE];
  202.  
  203. #ifdef HAVE_SOCKETS
  204.     STD_VOID_SYSTEM_CALL (syscall_gethostname,
  205.               UX_gethostname (this_host_name, HOSTNAMESIZE));
  206.     PRIMITIVE_RETURN
  207.       (char_pointer_to_string ((unsigned char *) this_host_name));
  208. #else
  209.     strcpy (this_host_name, "unknown-host");
  210. #endif
  211.   }
  212. }
  213.  
  214.  
  215.  
  216.  
  217. DEFINE_PRIMITIVE ("INSTRUCTION-ADDRESS->COMPILED-CODE-BLOCK",
  218.           Prim_instruction_address_to_compiled_code_block, 1, 1, 0)
  219. {
  220.   PRIMITIVE_HEADER (1);
  221.   {
  222.       extern SCHEME_OBJECT find_ccblock(long);
  223.       long the_pc = (INTEGER_P (ARG_REF (1)))
  224.     ? (integer_to_long (ARG_REF (1)))
  225.     : ((long) OBJECT_ADDRESS (ARG_REF (1)));
  226.       PRIMITIVE_RETURN (find_ccblock (the_pc));
  227.   }
  228. }
  229.  
  230.