/*
* Convert a timeval into a Scheme time record.
*/
s48_ref_t
s48_enter_time(s48_call_t call, struct timeval *now)
{
s48_ref_t sch_time;
sch_time = s48_make_record_2(call, time_type_binding);
s48_unsafe_record_set_2(call, sch_time, 0, s48_enter_long_2(call, now->tv_sec));
s48_unsafe_record_set_2(call, sch_time, 1, s48_enter_long_2(call, now->tv_usec));
return sch_time;
}
static s48_ref_t
posix_initialize_named_errnos(s48_call_t call)
{
int i, length;
s48_ref_t named_errnos;
s48_shared_binding_check_2(call, posix_errnos_vector_binding);
named_errnos = s48_shared_binding_ref_2(call, posix_errnos_vector_binding);
if(! s48_vector_p_2(call, named_errnos))
s48_assertion_violation_2(call,
"posix_initialize_named_errnos", "not a vector", 1,
named_errnos);
length = s48_unsafe_vector_length_2(call, named_errnos);
for(i = 0; i < length; i++) {
s48_ref_t named_errno = s48_unsafe_vector_ref_2(call, named_errnos, i);
int canonical = s48_extract_long_2(call, s48_unsafe_record_ref_2(call, named_errno, 1));
int c_errno = errno_map[canonical];
s48_ref_t scm_errno = (c_errno == -1) ?
s48_false_2(call) :
s48_enter_long_2(call, c_errno);
s48_unsafe_record_set_2(call, named_errno, 2, scm_errno); }
return s48_unspecific_2(call);
}
/* returns the difference in seconds between UTC and local time */
s48_ref_t
s48_get_timezone(s48_call_t call)
{
#ifdef HAVE_TM_GMTOFF
time_t helper_time;
struct tm broken_time;
if ((helper_time = time(NULL)) == -1)
s48_assertion_violation_2(call, "os_time", "unknown error calling time()", 0);
localtime_r(&helper_time, &broken_time);
return s48_enter_long_2(call, broken_time.tm_gmtoff);
#else /* not HAVE_TM_GMTOFF */
/* On systems that do not have the tm_gmtoff field in struct tm,
there is no reliable way to get the timezone. We do not
support timezones on these systems. */
return s48_enter_long_2(call, 0);
#endif /* not HAVE_TM_GMTOFF */
}
s48_ref_t open_ctty(s48_call_t call, s48_ref_t sch_ttyname, s48_ref_t sch_flags) {
int fd = open(s48_extract_byte_vector_2(call, sch_ttyname),
s48_extract_long_2(call, sch_flags));
#if defined(TIOCSCTTY) && !defined(CIBAUD) && !defined(__hpux)
/* 4.3+BSD way to acquire control tty. !CIBAUD rules out SunOS.
** This code stolen from Steven's *Advanced Prog. in the Unix Env.*
*/
if( (fd >= 0) && (ioctl(fd, TIOCSCTTY, (char *) 0) < 0) ) {
int e = errno;
close(fd);
s48_os_error_2(call, "open_ctty", e, 2, sch_ttyname, sch_flags);
}
#endif
if (fd == -1)
s48_os_error_2(call, "open_ctty", errno, 2, sch_ttyname, sch_flags);
return s48_enter_long_2(call, fd);
}
s48_ref_t scheme_tcgetattr(s48_call_t call, s48_ref_t sch_fd,
s48_ref_t sch_control_chars) {
struct termios t;
int fd = s48_extract_long_2(call, sch_fd);
int i;
int result;
s48_ref_t sch_iflag = s48_unspecific_2(call);
s48_ref_t sch_oflag = s48_unspecific_2(call);
s48_ref_t sch_cflag = s48_unspecific_2(call);
s48_ref_t sch_lflag = s48_unspecific_2(call);
s48_ref_t sch_ispeed = s48_unspecific_2(call);
s48_ref_t sch_ospeed = s48_unspecific_2(call);
s48_ref_t sch_retval = s48_unspecific_2(call);
if (isatty(fd) == 0) {
fprintf(stderr, "%d is not a tty\n", fd);
return s48_false_2(call);
}
result = tcgetattr(s48_extract_long_2(call, sch_fd), &t);
if (result == -1) {
s48_os_error_2(call, "scheme_tcgetattr", errno, 2, sch_fd, sch_control_chars);
}
for (i = 0; i < NCCS; i++)
s48_string_set_2(call, sch_control_chars, i, t.c_cc[i]);
{
sch_iflag = s48_enter_long_2(call, t.c_iflag);
sch_oflag = s48_enter_long_2(call, t.c_oflag);
sch_cflag = s48_enter_long_2(call, t.c_cflag);
sch_lflag = s48_enter_long_2(call, t.c_lflag);
sch_ispeed = s48_enter_long_2(call, cfgetispeed(&t));
sch_ospeed = s48_enter_long_2(call, cfgetospeed(&t));
sch_retval = s48_cons_2(call, sch_ospeed, s48_null_2(call));
sch_retval = s48_cons_2(call, sch_ispeed, sch_retval);
sch_retval = s48_cons_2(call, sch_lflag, sch_retval);
sch_retval = s48_cons_2(call, sch_cflag, sch_retval);
sch_retval = s48_cons_2(call, sch_oflag, sch_retval);
sch_retval = s48_cons_2(call, sch_iflag, sch_retval);
return sch_retval;
}
}
/* Open an available pty, returning a file descriptor.
Return -1 on failure. */
s48_ref_t allocate_pty(s48_call_t call) {
/* Unix98 standardized grantpt, unlockpt, and ptsname, but not the
functions required to open a master pty in the first place :-(
Modern Unix systems all seems to have convenience methods to open
a master pty fd in one function call, but there is little
agreement on how to do it.
allocate_pty() tries all the different known easy ways of opening
a pty. In case of failure, we resort to the old BSD-style pty
grovelling code in allocate_pty_the_old_fashioned_way(). */
int master_fd = -1;
const char *slave_name = NULL;
const char* clone = NULL;
int off = 0;
s48_ref_t scm_slave_name = s48_unspecific_2(call);
master_fd = allocate_master(&slave_name, &clone);
if (master_fd == -1)
return s48_false_2(call);
if (slave_name == NULL){
slave_name = allocate_slave_name(master_fd, clone);
if (slave_name == NULL){
retry_close (master_fd);
return s48_false_2(call);
}
}
scm_slave_name = s48_enter_byte_string_2(call, (char *) slave_name);
#ifdef TIOCPKT
/* In some systems (Linux through 2.0.0, at least), packet mode doesn't
get cleared when a pty is closed, so we need to clear it here.
Linux pre2.0.13 contained an attempted fix for this (from Ted Ts'o,
[email protected]), but apparently it messed up rlogind and telnetd, so he
removed the fix in pre2.0.14. - [email protected]
*/
ioctl (master_fd, TIOCPKT, (char *)&off);
#endif /* TIOCPKT */
/* We jump through some hoops to frob the pty.
It's not obvious that checking the return code here is useful. */
/* "The grantpt() function will fail if it is unable to successfully
invoke the setuid root program. It may also fail if the
application has installed a signal handler to catch SIGCHLD
signals." */
#if defined (HAVE_GRANTPT) || defined (HAVE_UNLOCKPT)
BLOCK_SIGNAL (SIGCHLD);
#if defined (HAVE_GRANTPT)
grantpt (master_fd);
#endif /* HAVE_GRANTPT */
#if defined (HAVE_UNLOCKPT)
unlockpt (master_fd);
#endif
UNBLOCK_SIGNAL (SIGCHLD);
#endif /* HAVE_GRANTPT || HAVE_UNLOCKPT */
fcntl(master_fd, F_SETFL, O_NONBLOCK);
return s48_cons_2(call, s48_enter_long_2(call, master_fd), scm_slave_name);
}
s48_ref_t sch_tcgetpgrp(s48_call_t call, s48_ref_t sch_fd) {
int ret = tcgetpgrp (s48_extract_long_2(call, sch_fd));
if (ret == -1)
s48_os_error_2(call, "sch_tcgetpgrp", errno, 1, sch_fd);
return s48_enter_long_2(call, ret);
}
