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); }