+
+/* crypt() returns a pointer to a static buffer, so we use scm_i_misc_mutex
+ to avoid another thread overwriting it. A test program running crypt
+ continuously in two threads can be quickly seen tripping this problem.
+ crypt() is pretty slow normally, so a mutex shouldn't add much overhead.
+
+ glibc has a thread-safe crypt_r, but (in version 2.3.2) it runs a lot
+ slower (about 5x) than plain crypt if you pass an uninitialized data
+ block each time. Presumably there's some one-time setups. The best way
+ to use crypt_r for parallel execution in multiple threads would probably
+ be to maintain a little pool of initialized crypt_data structures, take
+ one and use it, then return it to the pool. That pool could be garbage
+ collected so it didn't add permanently to memory use if only a few crypt
+ calls are made. But we expect crypt will be used rarely, and even more
+ rarely will there be any desire for lots of parallel execution on
+ multiple cpus. So for now we don't bother with anything fancy, just
+ ensure it works. */
+
+#if HAVE_CRYPT
+SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
+ (SCM key, SCM salt),
+ "Encrypt @var{key} using @var{salt} as the salt value to the\n"
+ "crypt(3) library call.")
+#define FUNC_NAME s_scm_crypt
+{
+ SCM ret;
+ char *c_key, *c_salt;
+
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ c_key = scm_to_locale_string (key);
+ scm_dynwind_free (c_key);
+ c_salt = scm_to_locale_string (salt);
+ scm_dynwind_free (c_salt);
+
+ ret = scm_from_locale_string (crypt (c_key, c_salt));
+
+ scm_dynwind_end ();
+ return ret;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CRYPT */
+
+#if HAVE_CHROOT
+SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
+ (SCM path),
+ "Change the root directory to that specified in @var{path}.\n"
+ "This directory will be used for path names beginning with\n"
+ "@file{/}. The root directory is inherited by all children\n"
+ "of the current process. Only the superuser may change the\n"
+ "root directory.")
+#define FUNC_NAME s_scm_chroot
+{
+ int rv;
+
+ WITH_STRING (path, c_path,
+ rv = chroot (c_path));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CHROOT */
+
+
+#ifdef __MINGW32__
+/* Wrapper function to supplying `getlogin()' under Windows. */
+static char * getlogin (void)
+{
+ static char user[256];
+ static unsigned long len = 256;
+
+ if (!GetUserName (user, &len))
+ return NULL;
+ return user;
+}
+#endif /* __MINGW32__ */
+
+
+#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
+SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
+ (void),
+ "Return a string containing the name of the user logged in on\n"
+ "the controlling terminal of the process, or @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_getlogin
+{
+ char * p;
+
+ p = getlogin ();
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_from_locale_string (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETLOGIN */
+
+#if HAVE_CUSERID
+SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
+ (void),
+ "Return a string containing a user name associated with the\n"
+ "effective user id of the process. Return @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_cuserid
+{
+ char buf[L_cuserid];
+ char * p;
+
+ p = cuserid (buf);
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_from_locale_string (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CUSERID */
+
+#if HAVE_GETPRIORITY
+SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
+ (SCM which, SCM who),
+ "Return the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user. Return\n"
+ "the highest priority (lowest numerical value) of any of the\n"
+ "specified processes.")
+#define FUNC_NAME s_scm_getpriority
+{
+ int cwhich, cwho, ret;
+
+ cwhich = scm_to_int (which);
+ cwho = scm_to_int (who);
+
+ /* We have to clear errno and examine it later, because -1 is a
+ legal return value for getpriority(). */
+ errno = 0;
+ ret = getpriority (cwhich, cwho);
+ if (errno != 0)
+ SCM_SYSERROR;
+ return scm_from_int (ret);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPRIORITY */
+
+#if HAVE_SETPRIORITY
+SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
+ (SCM which, SCM who, SCM prio),
+ "Set the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user.\n"
+ "@var{prio} is a value in the range -20 and 20, the default\n"
+ "priority is 0; lower priorities cause more favorable\n"
+ "scheduling. Sets the priority of all of the specified\n"
+ "processes. Only the super-user may lower priorities.\n"
+ "The return value is not specified.")
+#define FUNC_NAME s_scm_setpriority
+{
+ int cwhich, cwho, cprio;
+
+ cwhich = scm_to_int (which);
+ cwho = scm_to_int (who);
+ cprio = scm_to_int (prio);
+
+ if (setpriority (cwhich, cwho, cprio) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETPRIORITY */
+
+#if HAVE_GETPASS
+SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
+ (SCM prompt),
+ "Display @var{prompt} to the standard error output and read\n"
+ "a password from @file{/dev/tty}. If this file is not\n"
+ "accessible, it reads from standard input. The password may be\n"
+ "up to 127 characters in length. Additional characters and the\n"
+ "terminating newline character are discarded. While reading\n"
+ "the password, echoing and the generation of signals by special\n"
+ "characters is disabled.")
+#define FUNC_NAME s_scm_getpass
+{
+ char * p;
+ SCM passwd;
+
+ SCM_VALIDATE_STRING (1, prompt);
+
+ WITH_STRING (prompt, c_prompt,
+ p = getpass(c_prompt));
+ passwd = scm_from_locale_string (p);
+
+ /* Clear out the password in the static buffer. */
+ memset (p, 0, strlen (p));
+
+ return passwd;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPASS */
+
+/* Wrapper function for flock() support under M$-Windows. */
+#ifdef __MINGW32__
+# include <io.h>
+# include <sys/locking.h>
+# include <errno.h>
+# ifndef _LK_UNLCK
+ /* Current MinGW package fails to define this. *sigh* */
+# define _LK_UNLCK 0
+# endif
+# define LOCK_EX 1
+# define LOCK_UN 2
+# define LOCK_SH 4
+# define LOCK_NB 8
+
+static int flock (int fd, int operation)
+{
+ long pos, len;
+ int ret, err;
+
+ /* Disable invalid arguments. */
+ if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
+ ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
+ ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Determine mode of operation and discard unsupported ones. */
+ if (operation == (LOCK_NB | LOCK_EX))
+ operation = _LK_NBLCK;
+ else if (operation & LOCK_UN)
+ operation = _LK_UNLCK;
+ else if (operation == LOCK_EX)
+ operation = _LK_LOCK;
+ else
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Save current file pointer and seek to beginning. */
+ if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
+ return -1;
+ lseek (fd, 0L, SEEK_SET);
+
+ /* Deadlock if necessary. */
+ do
+ {
+ ret = _locking (fd, operation, len);
+ }
+ while (ret == -1 && errno == EDEADLOCK);
+
+ /* Produce meaningful error message. */
+ if (errno == EACCES && operation == _LK_NBLCK)
+ err = EDEADLOCK;
+ else
+ err = errno;
+
+ /* Return to saved file position pointer. */
+ lseek (fd, pos, SEEK_SET);
+ errno = err;
+ return ret;
+}
+#endif /* __MINGW32__ */
+
+#if HAVE_FLOCK || defined (__MINGW32__)
+SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
+ (SCM file, SCM operation),
+ "Apply or remove an advisory lock on an open file.\n"
+ "@var{operation} specifies the action to be done:\n"
+ "\n"
+ "@defvar LOCK_SH\n"
+ "Shared lock. More than one process may hold a shared lock\n"
+ "for a given file at a given time.\n"
+ "@end defvar\n"
+ "@defvar LOCK_EX\n"
+ "Exclusive lock. Only one process may hold an exclusive lock\n"
+ "for a given file at a given time.\n"
+ "@end defvar\n"
+ "@defvar LOCK_UN\n"
+ "Unlock the file.\n"
+ "@end defvar\n"
+ "@defvar LOCK_NB\n"
+ "Don't block when locking. This is combined with one of the\n"
+ "other operations using @code{logior}. If @code{flock} would\n"
+ "block an @code{EWOULDBLOCK} error is thrown.\n"
+ "@end defvar\n"
+ "\n"
+ "The return value is not specified. @var{file} may be an open\n"
+ "file descriptor or an open file descriptor port.\n"
+ "\n"
+ "Note that @code{flock} does not lock files across NFS.")
+#define FUNC_NAME s_scm_flock
+{
+ int fdes;
+
+ if (scm_is_integer (file))
+ fdes = scm_to_int (file);
+ else
+ {
+ SCM_VALIDATE_OPFPORT (2, file);
+
+ fdes = SCM_FPORT_FDES (file);
+ }
+ if (flock (fdes, scm_to_int (operation)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_FLOCK */
+
+#if HAVE_SETHOSTNAME
+SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
+ (SCM name),
+ "Set the host name of the current processor to @var{name}. May\n"
+ "only be used by the superuser. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_sethostname
+{
+ int rv;
+
+ WITH_STRING (name, c_name,
+ rv = sethostname (c_name, strlen(c_name)));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETHOSTNAME */
+
+
+#if HAVE_GETHOSTNAME
+SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
+ (void),
+ "Return the host name of the current processor.")
+#define FUNC_NAME s_scm_gethostname
+{
+#ifdef MAXHOSTNAMELEN
+
+ /* Various systems define MAXHOSTNAMELEN (including Solaris in fact).
+ * On GNU/Linux this doesn't include the terminating '\0', hence "+ 1". */
+ const int len = MAXHOSTNAMELEN + 1;
+ char *const p = scm_malloc (len);
+ const int res = gethostname (p, len);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
+
+#else
+
+ /* Default 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
+ * large enough. SUSv2 specifies 255 maximum too, apparently. */
+ int len = 256;
+ int res;
+ char *p;
+
+# if HAVE_SYSCONF && defined (_SC_HOST_NAME_MAX)
+
+ /* POSIX specifies the HOST_NAME_MAX system parameter for the max size,
+ * which may reflect a particular kernel configuration.
+ * Must watch out for this existing but giving -1, as happens for instance
+ * in gnu/linux glibc 2.3.2. */
+ {
+ const long int n = sysconf (_SC_HOST_NAME_MAX);
+ if (n != -1L)
+ len = n;
+ }
+
+# endif
+
+ p = scm_malloc (len);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
+
+ res = gethostname (p, len);
+ while (res == -1 && errno == ENAMETOOLONG)
+ {
+ len *= 2;
+
+ /* scm_realloc may throw an exception. */
+ p = scm_realloc (p, len);
+ res = gethostname (p, len);
+ }
+
+#endif
+
+ if (res == -1)
+ {
+ const int save_errno = errno;
+
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
+ free (p);
+
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ else
+ {
+ /* scm_from_locale_string may throw an exception. */
+ const SCM name = scm_from_locale_string (p);
+
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
+ free (p);
+
+ return name;
+ }
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETHOSTNAME */
+
+
HCoop / bpt / guile.git / blobdiff