static s48_ref_t
posix_set_close_on_exec(s48_call_t call, s48_ref_t channel, s48_ref_t value)
{
int status, new_status;
int c_fd;
if (!s48_channel_p_2(call, channel) ||
s48_eq_p_2(call,
s48_channel_status_2(call, channel),
s48_channel_status_closed_2(call)))
s48_assertion_violation_2(call, "posix_set_close_on_exec", "not an open channel", 1, channel);
c_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_GETFD));
if (s48_extract_boolean_2(call, value))
new_status = status | FD_CLOEXEC;
else
new_status = status & ! FD_CLOEXEC;
if (new_status != status)
RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_SETFD, new_status));
return s48_unspecific_2(call);
}
static s48_ref_t
posix_io_flags(s48_call_t call, s48_ref_t channel, s48_ref_t options)
{
int status;
int c_fd;
if (!s48_channel_p_2(call, channel) ||
s48_eq_p_2(call,
s48_channel_status_2(call, channel),
s48_channel_status_closed_2(call)))
s48_assertion_violation_2(call, "posix_io_flags", "not an open channel", 1, channel);
c_fd = s48_unsafe_extract_long_2(call, s48_unsafe_channel_os_index_2(call, channel));
if (s48_false_p_2(call, options)) {
RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_GETFL));
return s48_enter_file_options(call, status);
}
else {
int c_options = s48_extract_file_options(call, options);
RETRY_OR_RAISE_NEG(status, fcntl(c_fd, F_SETFL, c_options));
return s48_unspecific_2(call);
}
}
static s48_ref_t
posix_openlog(s48_call_t call,
s48_ref_t sch_ident, s48_ref_t sch_options, s48_ref_t sch_facility)
{
if (syslog_open)
s48_assertion_violation_2(call,
"posix_openlog", "syslog is already open",
3, sch_ident, sch_options, sch_facility);
{
/*
* openlog doesn't copy the input string, at least not
* on every system. That's just great.
*/
char* ident = s48_extract_byte_vector_readonly_2(call, sch_ident);
size_t ident_size = strlen(ident) + 1;
if (ident_size > syslog_ident_size)
{
if (syslog_ident != syslog_ident_initial)
free(syslog_ident);
syslog_ident = malloc(ident_size);
if (syslog_ident == NULL)
s48_out_of_memory_error_2(call);
syslog_ident_size = ident_size;
}
strcpy(syslog_ident, ident);
openlog(syslog_ident,
extract_syslog_options(call, sch_options),
extract_syslog_facility(call, sch_facility));
}
syslog_open = 1;
return s48_unspecific_2(call);
}
s48_ref_t sch_tcsendbreak(s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_duration) {
if (tcsendbreak (s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_duration)) == -1)
s48_os_error_2(call, "sch_tcsendbreak", errno, 2, sch_fd, sch_duration);
return s48_unspecific_2(call);
}
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);
}
static s48_ref_t
posix_closelog(s48_call_t call)
{
if (!syslog_open)
s48_assertion_violation_2(call, "posix_closelog", "syslog isn't open", 0);
closelog();
syslog_open = 0;
return s48_unspecific_2(call);
}
static s48_ref_t
shared_object_dlclose(s48_call_t call, s48_ref_t handle)
{
HINSTANCE native_handle = s48_extract_value_2(call, handle, HINSTANCE);
if (!FreeLibrary(native_handle) < 0)
s48_os_error_2(call, "shared_object_dlclose", GetLastError(), 1, handle);
return s48_unspecific_2(call);
}
static s48_ref_t
shared_object_call_thunk(s48_call_t call, s48_ref_t value)
{
thunk entry;
entry = s48_extract_value_2(call, value, thunk);
entry();
return s48_unspecific_2(call);
}
s48_ref_t make_ctty(s48_call_t call, s48_ref_t sch_fd) {
int fd = s48_extract_long_2(call, sch_fd);
#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) ) {
s48_os_error_2(call, "make_ctty", errno, 1, sch_fd);
}
#endif
return s48_unspecific_2(call);
}
static s48_ref_t
posix_syslog(s48_call_t call,
s48_ref_t sch_level, s48_ref_t sch_opt_facility, s48_ref_t sch_message)
{
int facility = s48_false_p_2(call, sch_opt_facility)
? 0 : extract_syslog_facility(call, sch_opt_facility);
int level = extract_syslog_level(call, sch_level);
if (!syslog_open)
s48_assertion_violation_2(call, "posix_syslog", "syslog isn't open",
3, sch_level, sch_opt_facility, sch_message);
syslog(facility | level, "%s", s48_extract_byte_vector_readonly_2(call, sch_message));
return s48_unspecific_2(call);
}
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;
}
}
s48_ref_t scheme_tcsetattr(s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_option,
s48_ref_t sch_control_chars,
s48_ref_t sch_iflag,
s48_ref_t sch_oflag,
s48_ref_t sch_cflag,
s48_ref_t sch_lflag,
s48_ref_t sch_ispeed, s48_ref_t sch_ospeed,
s48_ref_t sch_min, s48_ref_t sch_time) {
struct termios t;
memcpy(t.c_cc, s48_extract_latin_1_from_string_2(call, sch_control_chars), NCCS);
/* This first clause of this conditional test will hopefully
** resolve the branch at compile time. However, since VMIN/VEOF
** and VTIME/VEOL are allowed by POSIX to colllide, we have to check.
** If they do collide, we set EOF & EOL in canonical mode, and MIN & TIME
** in raw mode. Ah, Unix.
*/
t.c_iflag = s48_extract_long_2(call, sch_iflag);
t.c_oflag = s48_extract_long_2(call, sch_oflag);
t.c_cflag = s48_extract_long_2(call, sch_cflag);
t.c_lflag = s48_extract_long_2(call, sch_lflag);
if( (VMIN != VEOF && VTIME != VEOL) || !(t.c_lflag & ICANON) ) {
t.c_cc[VMIN] = s48_extract_long_2(call, sch_min);
t.c_cc[VTIME] = s48_extract_long_2(call, sch_time);
}
cfsetispeed(&t, s48_extract_long_2(call, sch_ispeed));
cfsetospeed(&t, s48_extract_long_2(call, sch_ospeed));
if (tcsetattr(s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_option),
&t)
== -1)
s48_os_error_2(call, "scheme_tcsetattr", errno, 1, sch_fd);
return s48_unspecific_2(call);
}
s48_ref_t pty2tty(s48_call_t call, s48_ref_t sch_fd) {
int fd = s48_extract_long_2(call, sch_fd);
#if defined (HAVE_ISASTREAM) && defined (I_PUSH)
if (isastream (fd))
{
# if defined (I_FIND)
# define stream_module_pushed(fd, module) (ioctl (fd, I_FIND, module) == 1)
# else
# define stream_module_pushed(fd, module) 0
# endif
if ((! stream_module_pushed (fd, "ptem")) &&
(ioctl (fd, I_PUSH, "ptem") < 0))
s48_os_error_2(call, "pty2tty", errno, 1, sch_fd);
if ((! stream_module_pushed (fd, "ldterm")) &&
(ioctl (fd, I_PUSH, "ldterm") < 0))
s48_os_error_2(call, "pty2tty", errno, 1, sch_fd);
if ((! stream_module_pushed (fd, "ttcompat")) &&
(ioctl (fd, I_PUSH, "ttcompat") < 0))
s48_os_error_2(call, "pty2tty", errno, 1, sch_fd);
}
#endif /* defined (HAVE_ISASTREAM) && defined (I_PUSH) */
return s48_unspecific_2(call);
}
s48_ref_t sch_tcflow(s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_action) {
if (tcflow (s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_action)) == -1)
s48_os_error_2(call, "sch_tcflow", errno, 2, sch_fd, sch_action);
return s48_unspecific_2(call);
}
/* 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_tcsetpgrp (s48_call_t call, s48_ref_t sch_fd, s48_ref_t sch_pid) {
if (tcsetpgrp (s48_extract_long_2(call, sch_fd),
s48_extract_long_2(call, sch_pid)) == -1)
s48_os_error_2(call, "sch_tcsetpgrp", errno, 2, sch_fd, sch_pid);
return s48_unspecific_2(call);
}
s48_ref_t sch_tcdrain(s48_call_t call, s48_ref_t sch_fd) {
if (tcdrain (s48_extract_long_2(call, sch_fd)) == -1)
s48_os_error_2(call, "sch_tcdrain", errno, 1, sch_fd);
return s48_unspecific_2(call);
}