ScmObj Scm_TLSConnect(ScmTLS* t, int fd)
{
#if defined(GAUCHE_USE_AXTLS)
context_check(t, "connect");
if (t->conn) Scm_SysError("attempt to connect already-connected TLS %S", t);
t->conn = ssl_client_new(t->ctx, fd, 0, 0);
if (SSL_OK != ssl_handshake_status(t->conn)) {
Scm_SysError("TLS handshake failed");
}
#endif /*GAUCHE_USE_AXTLS*/
return SCM_OBJ(t);
}
static void ITIMER_START(void)
{
ScmVM *vm = Scm_VM();
vm->prof->hTimerEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
if (vm->prof->hTimerEvent == NULL) {
Scm_SysError("CreateEvent failed");
}
vm->prof->hObserverThread = (HANDLE)_beginthreadex(NULL, 0, observer_thread,
(void*)vm, 0, NULL);
if (vm->prof->hObserverThread == NULL) {
Scm_SysError("_beginthreadex failed");
}
}
ScmObj Scm_SocketAccept(ScmSocket *sock)
{
Socket newfd;
struct sockaddr_storage addrbuf;
socklen_t addrlen = sizeof(addrbuf);
ScmSocket *newsock;
ScmClass *addrClass = Scm_ClassOf(SCM_OBJ(sock->address));
CLOSE_CHECK(sock->fd, "accept from", sock);
SCM_SYSCALL(newfd, accept(sock->fd, (struct sockaddr*)&addrbuf, &addrlen));
if (SOCKET_INVALID(newfd)) {
if (errno == EAGAIN) {
return SCM_FALSE;
} else {
Scm_SysError("accept(2) failed");
}
}
newsock = make_socket(newfd, sock->type);
newsock->address =
SCM_SOCKADDR(Scm_MakeSockAddr(addrClass,
(struct sockaddr*)&addrbuf,
addrlen));
newsock->status = SCM_SOCKET_STATUS_CONNECTED;
return SCM_OBJ(newsock);
}
/* ADDRS is a list of socket addresses; if 'from' address type matches
one of them, it is used to store the information so that we can avoid
allocation. If no addresses match the incoming type, and ADDRS is
a complete list, the information of 'from' is discarded. If no addresses
match the incoming type, and the last cdr of ADDRS is #t (this case
includes ADDRS == #t), a new sockaddr is allocated and returned. */
ScmObj Scm_SocketRecvFromX(ScmSocket *sock, ScmUVector *buf,
ScmObj addrs, int flags)
{
int r;
u_int size;
struct sockaddr_storage from;
socklen_t fromlen = sizeof(from);
ScmObj addr = SCM_FALSE;
CLOSE_CHECK(sock->fd, "recv from", sock);
char *z = get_message_buffer(buf, &size);
SCM_SYSCALL(r, recvfrom(sock->fd, z, size, flags,
(struct sockaddr*)&from, &fromlen));
if (r < 0) {
Scm_SysError("recvfrom(2) failed");
}
ScmObj cp;
SCM_FOR_EACH(cp, addrs) {
ScmObj a = SCM_CAR(cp);
if (Scm_SockAddrP(a)) {
if (SCM_SOCKADDR_FAMILY(a) == from.ss_family) {
memcpy(&SCM_SOCKADDR(a)->addr, &from, SCM_SOCKADDR(a)->addrlen);
addr = a;
break;
}
}
}
ScmObj Scm_TLSAccept(ScmTLS* t, int fd)
{
#if defined(GAUCHE_USE_AXTLS)
context_check(t, "accept");
if (t->conn) Scm_SysError("attempt to connect already-connected TLS %S", t);
t->conn = ssl_server_new(t->ctx, fd);
#endif /*GAUCHE_USE_AXTLS*/
return SCM_OBJ(t);
}
ScmObj Scm_SocketSend(ScmSocket *sock, ScmObj msg, int flags)
{
int r;
u_int size;
CLOSE_CHECK(sock->fd, "send to", sock);
const char *cmsg = get_message_body(msg, &size);
SCM_SYSCALL(r, send(sock->fd, cmsg, size, flags));
if (r < 0) Scm_SysError("send(2) failed");
return SCM_MAKE_INT(r);
}
ScmObj Scm_SocketListen(ScmSocket *sock, int backlog)
{
int r;
CLOSE_CHECK(sock->fd, "listen to", sock);
SCM_SYSCALL(r, listen(sock->fd, backlog));
if (r < 0) {
Scm_SysError("listen(2) failed");
}
sock->status = SCM_SOCKET_STATUS_LISTENING;
return SCM_OBJ(sock);
}
ScmObj Scm_SocketRecv(ScmSocket *sock, int bytes, int flags)
{
int r;
CLOSE_CHECK(sock->fd, "recv from", sock);
char *buf = SCM_NEW_ATOMIC2(char*, bytes);
SCM_SYSCALL(r, recv(sock->fd, buf, bytes, flags));
if (r < 0) {
Scm_SysError("recv(2) failed");
}
return Scm_MakeString(buf, r, r, SCM_STRING_INCOMPLETE);
}
ScmObj Scm_SocketConnect(ScmSocket *sock, ScmSockAddr *addr)
{
int r;
CLOSE_CHECK(sock->fd, "connect to", sock);
SCM_SYSCALL(r, connect(sock->fd, &addr->addr, addr->addrlen));
if (r < 0) {
Scm_SysError("connect failed to %S", addr);
}
sock->address = addr;
sock->status = SCM_SOCKET_STATUS_CONNECTED;
return SCM_OBJ(sock);
}
ScmObj Scm_SocketRecvX(ScmSocket *sock, ScmUVector *buf, int flags)
{
int r;
u_int size;
CLOSE_CHECK(sock->fd, "recv from", sock);
char *z = get_message_buffer(buf, &size);
SCM_SYSCALL(r, recv(sock->fd, z, size, flags));
if (r < 0) {
Scm_SysError("recv(2) failed");
}
return Scm_MakeInteger(r);
}
ScmObj Scm_SocketSendTo(ScmSocket *sock, ScmObj msg, ScmSockAddr *to,
int flags)
{
int r;
u_int size;
CLOSE_CHECK(sock->fd, "send to", sock);
const char *cmsg = get_message_body(msg, &size);
SCM_SYSCALL(r, sendto(sock->fd, cmsg, size, flags,
&SCM_SOCKADDR(to)->addr, SCM_SOCKADDR(to)->addrlen));
if (r < 0) Scm_SysError("sendto(2) failed");
return SCM_MAKE_INT(r);
}
ScmObj Scm_SocketBind(ScmSocket *sock, ScmSockAddr *addr)
{
int r;
CLOSE_CHECK(sock->fd, "bind", sock);
SCM_SYSCALL(r, bind(sock->fd, &addr->addr, addr->addrlen));
if (r < 0) {
Scm_SysError("bind failed to %S", addr);
}
/* The system may assign different address than <addr>, especially when
<addr> contains some 'wild card' (e.g. port=0). We call getsockname
to obtain the exact address. Patch provided by ODA Hideo */
ScmSockAddr *naddr = SCM_SOCKADDR(
Scm_MakeSockAddr(SCM_CLASS_OF(addr), &addr->addr, addr->addrlen));
SCM_SYSCALL(r, getsockname(sock->fd, &naddr->addr, &naddr->addrlen));
if (r < 0) {
Scm_SysError("getsockname failed to %S", addr);
}
sock->address = naddr;
sock->status = SCM_SOCKET_STATUS_BOUND;
return SCM_OBJ(sock);
}
ScmObj Scm_SocketGetPeerName(ScmSocket *sock)
{
int r;
struct sockaddr_storage addrbuf;
socklen_t addrlen = sizeof(addrbuf);
CLOSE_CHECK(sock->fd, "get the name of", sock);
SCM_SYSCALL(r, getpeername(sock->fd, (struct sockaddr*)&addrbuf, &addrlen));
if (r < 0) {
Scm_SysError("getpeername(2) failed");
}
return SCM_OBJ(Scm_MakeSockAddr(NULL, (struct sockaddr*)&addrbuf, addrlen));
}
ScmObj Scm_SocketShutdown(ScmSocket *s, int how)
{
int r;
if (s->status != SCM_SOCKET_STATUS_CONNECTED) {
return SCM_FALSE;
}
SCM_SYSCALL(r, shutdown(s->fd, how));
if (r < 0) {
Scm_SysError("socket shutdown failed for %S", SCM_OBJ(s));
}
s->status = SCM_SOCKET_STATUS_SHUTDOWN;
return SCM_TRUE;
}
ScmObj Scm_TLSRead(ScmTLS* t)
{
#if defined(GAUCHE_USE_AXTLS)
context_check(t, "read");
close_check(t, "read");
int r; uint8_t* buf;
while ((r = ssl_read(t->conn, &buf)) == SSL_OK);
if (r < 0) Scm_SysError("ssl_read() failed");
return Scm_MakeString((char*) buf, r, r, SCM_STRING_INCOMPLETE);
#else /*!GAUCHE_USE_AXTLS*/
return SCM_FALSE;
#endif /*!GAUCHE_USE_AXTLS*/
}
ScmObj Scm_Forkpty(ScmObj slaveterm)
{
int master;
pid_t pid;
struct termios *term = NULL;
if (SCM_SYS_TERMIOS_P(slaveterm)) {
term = &SCM_SYS_TERMIOS(slaveterm)->term;
}
if ((pid = forkpty(&master, NULL, term, NULL)) < 0) {
Scm_SysError("forkpty failed");
}
return Scm_Values2(Scm_MakeInteger(pid), SCM_MAKE_INT(master));
}
ScmObj Scm_Openpty(ScmObj slaveterm)
{
int master, slave;
struct termios *term = NULL;
if (SCM_SYS_TERMIOS_P(slaveterm)) {
term = &SCM_SYS_TERMIOS(slaveterm)->term;
}
if (openpty(&master, &slave, NULL, term, NULL) < 0) {
Scm_SysError("openpty failed");
}
return Scm_Values2(SCM_MAKE_INT(master), SCM_MAKE_INT(slave));
}
ScmObj Scm_SocketSendMsg(ScmSocket *sock, ScmObj msg, int flags)
{
#if !GAUCHE_WINDOWS
int r;
u_int size;
CLOSE_CHECK(sock->fd, "send to", sock);
const char *cmsg = get_message_body(msg, &size);
SCM_SYSCALL(r, sendmsg(sock->fd, (struct msghdr*)cmsg, flags));
if (r < 0) Scm_SysError("sendmsg(2) failed");
return SCM_MAKE_INT(r);
#else /*GAUCHE_WINDOWS*/
Scm_Error("sendmsg is not implemented on this platform.");
return SCM_UNDEFINED; /* dummy */
#endif /*GAUCHE_WINDOWS*/
}
ScmObj Scm_SocketRecvFrom(ScmSocket *sock, int bytes, int flags)
{
int r;
struct sockaddr_storage from;
socklen_t fromlen = sizeof(from);
CLOSE_CHECK(sock->fd, "recv from", sock);
char *buf = SCM_NEW_ATOMIC2(char*, bytes);
SCM_SYSCALL(r, recvfrom(sock->fd, buf, bytes, flags,
(struct sockaddr*)&from, &fromlen));
if (r < 0) {
Scm_SysError("recvfrom(2) failed");
}
return Scm_Values2(Scm_MakeString(buf, r, r, SCM_STRING_INCOMPLETE),
Scm_MakeSockAddr(NULL, (struct sockaddr*)&from, fromlen));
}
ScmObj Scm_TLSWrite(ScmTLS* t, ScmObj msg)
{
#if defined(GAUCHE_USE_AXTLS)
context_check(t, "write");
close_check(t, "write");
int r;
u_int size;
const uint8_t* cmsg = get_message_body(msg, &size);
if ((r = ssl_write(t->conn, cmsg, size)) < 0) {
Scm_SysError("ssl_write() failed");
}
return SCM_MAKE_INT(r);
#else /*!GAUCHE_USE_AXTLS*/
return SCM_FALSE;
#endif /*!GAUCHE_USE_AXTLS*/
}
ScmObj Scm_MakeSocket(int domain, int type, int protocol)
{
intptr_t sock;
#if GAUCHE_WINDOWS
/* On Windows, sockets created by socket() call sets
WSA_FLAG_OVERLAPPED flag. When used in threads other than
primordial thread, I/O to/from such socket fails, since it
requires extra OVERLAPPED struct in win32 call (which can't
be done with POSIX calls). Directly using WSASocket allows
us to not set WSA_FLAG_OVERLAPPED flag. */
SCM_SYSCALL(sock, WSASocket(domain, type, protocol, NULL, 0, 0));
#else /*!GAUCHE_WINDOWS*/
SCM_SYSCALL(sock, socket(domain, type, protocol));
#endif /*!GAUCHE_WINDOWS*/
if (SOCKET_INVALID(sock)) Scm_SysError("couldn't create socket");
return SCM_OBJ(make_socket((Socket)sock, type));
}
/* Returns the statHash */
ScmObj Scm_ProfilerRawResult(void)
{
ScmVM *vm = Scm_VM();
if (vm->prof == NULL) return SCM_FALSE;
if (vm->prof->state == SCM_PROFILER_INACTIVE) return SCM_FALSE;
if (vm->prof->state == SCM_PROFILER_RUNNING) Scm_ProfilerStop();
if (vm->prof->errorOccurred > 0) {
Scm_Warn("profiler: An error has been occurred during saving profiling samples. The result may not be accurate");
}
Scm_ProfilerCountBufferFlush(vm);
/* collect samples in the current buffer */
collect_samples(vm->prof);
/* collect samples in the saved file */
off_t off;
SCM_SYSCALL(off, lseek(vm->prof->samplerFd, 0, SEEK_SET));
if (off == (off_t)-1) {
Scm_ProfilerReset();
Scm_Error("profiler: seek failed in retrieving sample data");
}
for (;;) {
ssize_t r = read(vm->prof->samplerFd, vm->prof->samples,
sizeof(ScmProfSample[1]) * SCM_PROF_SAMPLES_IN_BUFFER);
if (r <= 0) break;
vm->prof->currentSample = r / sizeof(ScmProfSample[1]);
collect_samples(vm->prof);
}
vm->prof->currentSample = 0;
#if defined(GAUCHE_WINDOWS)
if (vm->prof->samplerFd >= 0) {
close(vm->prof->samplerFd);
vm->prof->samplerFd = -1;
unlink(vm->prof->samplerFileName);
}
#else /* !GAUCHE_WINDOWS */
if (ftruncate(vm->prof->samplerFd, 0) < 0) {
Scm_SysError("profiler: failed to truncate temporary file");
}
#endif /* !GAUCHE_WINDOWS */
return SCM_OBJ(vm->prof->statHash);
}
/* Returns the statHash */
ScmObj Scm_ProfilerRawResult(void)
{
ScmVM *vm = Scm_VM();
if (vm->prof == NULL) return SCM_FALSE;
if (vm->prof->state == SCM_PROFILER_INACTIVE) return SCM_FALSE;
if (vm->prof->state == SCM_PROFILER_RUNNING) Scm_ProfilerStop();
if (vm->prof->errorOccurred > 0) {
Scm_Warn("profiler: An error has been occurred during saving profiling samples. The result may not be accurate");
}
Scm_ProfilerCountBufferFlush(vm);
/* collect samples in the current buffer */
collect_samples(vm->prof);
/* collect samples in the saved file */
off_t off;
SCM_SYSCALL(off, lseek(vm->prof->samplerFd, 0, SEEK_SET));
if (off == (off_t)-1) {
Scm_ProfilerReset();
Scm_Error("profiler: seek failed in retrieving sample data");
}
ScmObj sampler_port =
Scm_MakePortWithFd(SCM_FALSE, SCM_PORT_INPUT, vm->prof->samplerFd,
SCM_PORT_BUFFER_FULL, FALSE);
for (;;) {
ssize_t r = read(vm->prof->samplerFd, vm->prof->samples,
sizeof(ScmProfSample[1]) * SCM_PROF_SAMPLES_IN_BUFFER);
if (r <= 0) break;
vm->prof->currentSample = r / sizeof(ScmProfSample[1]);
collect_samples(vm->prof);
}
vm->prof->currentSample = 0;
if (ftruncate(vm->prof->samplerFd, 0) < 0) {
Scm_SysError("profiler: failed to truncate temporary file");
}
return SCM_OBJ(vm->prof->statHash);
}
ScmObj Scm_ForkptyAndExec(ScmString *file, ScmObj args, ScmObj iomap,
ScmObj slaveterm, ScmSysSigset *mask)
{
int argc = Scm_Length(args);
char **argv;
const char *program;
int *fds;
int master;
pid_t pid;
struct termios *term = NULL;
if (argc < 1) {
Scm_Error("argument list must have at least one element: %S", args);
}
argv = Scm_ListToCStringArray(args, TRUE, NULL);
program = Scm_GetStringConst(file);
if (SCM_SYS_TERMIOS_P(slaveterm)) {
term = &SCM_SYS_TERMIOS(slaveterm)->term;
}
fds = Scm_SysPrepareFdMap(iomap);
if ((pid = forkpty(&master, NULL, term, NULL)) < 0) {
Scm_SysError("forkpty failed");
}
if (pid == 0) {
Scm_SysSwapFds(fds);
if (mask) {
Scm_ResetSignalHandlers(&mask->set);
Scm_SysSigmask(SIG_SETMASK, mask);
}
execvp(program, (char *const*)argv);
/* here, we failed */
Scm_Panic("exec failed: %s: %s", program, strerror(errno));
}
return Scm_Values2(Scm_MakeInteger(pid), SCM_MAKE_INT(master));
}
/*=============================================================
* External API
*/
void Scm_ProfilerStart(void)
{
ScmVM *vm = Scm_VM();
ScmObj templat = Scm_StringAppendC(SCM_STRING(Scm_TmpDir()),
"/gauche-profXXXXXX", -1, -1);
char *templat_buf = Scm_GetString(SCM_STRING(templat)); /*mutable copy*/
if (!vm->prof) {
vm->prof = SCM_NEW(ScmVMProfiler);
vm->prof->state = SCM_PROFILER_INACTIVE;
vm->prof->samplerFd = Scm_Mkstemp(templat_buf);
vm->prof->currentSample = 0;
vm->prof->totalSamples = 0;
vm->prof->errorOccurred = 0;
vm->prof->currentCount = 0;
vm->prof->statHash =
SCM_HASH_TABLE(Scm_MakeHashTableSimple(SCM_HASH_EQ, 0));
unlink(templat_buf); /* keep anonymous tmpfile */
} else if (vm->prof->samplerFd < 0) {
vm->prof->samplerFd = Scm_Mkstemp(templat_buf);
unlink(templat_buf);
}
if (vm->prof->state == SCM_PROFILER_RUNNING) return;
vm->prof->state = SCM_PROFILER_RUNNING;
vm->profilerRunning = TRUE;
/* NB: this should be done globally!!! */
struct sigaction act;
act.sa_handler = sampler_sample;
sigfillset(&act.sa_mask);
act.sa_flags = SA_RESTART;
if (sigaction(SIGPROF, &act, NULL) < 0) {
Scm_SysError("sigaction failed");
}
ITIMER_START();
}
ScmObj Scm_SysFcntl(ScmObj port_or_fd, int op, ScmObj arg)
{
#if !defined(GAUCHE_WINDOWS)
int fd = Scm_GetPortFd(port_or_fd, TRUE), r;
switch (op) {
case F_GETFD:; case F_GETFL:;
#if defined(F_GETOWN) /* BSD and Linux specific */
case F_GETOWN:;
#endif /*F_GETOWN*/
#if defined(F_GETSIG) /* Linux specific */
case F_GETSIG:;
#endif /*F_GETSIG */
#if defined(F_GETLEASE) /* Linux specific */
case F_GETLEASE:;
#endif /*F_GETLEASE */
SCM_SYSCALL(r, fcntl(fd, op));
if (r == -1) { /*NB: F_GETOWN may return a negative value on success*/
Scm_SysError("fcntl(%s) failed", flag_name(op));
}
return Scm_MakeInteger(r);
case F_SETFD:; case F_SETFL:; case F_DUPFD:;
#if defined(F_SETOWN) /* BSD and Linux specific */
case F_SETOWN:;
#endif /*F_SETOWN*/
#if defined(F_SETSIG) /* Linux specific */
case F_SETSIG:;
#endif /*F_SETSIG */
#if defined(F_SETLEASE) /* Linux specific */
case F_SETLEASE:;
#endif /*F_SETLEASE */
#if defined(F_NOTIFY) /* Linux specific */
case F_NOTIFY:;
#endif /*F_NOTIFY */
if (!SCM_EXACTP(arg)) {
Scm_Error("exact integer required for fcntl(%s), but got %S",
flag_name(op), arg);
}
SCM_SYSCALL(r, fcntl(fd, op, Scm_GetInteger(arg)));
if (r < 0) {
Scm_SysError("fcntl(%s) failed", flag_name(op));
}
return Scm_MakeInteger(r);
case F_GETLK:; case F_SETLK:; case F_SETLKW:;
if (!SCM_SYS_FLOCK_P(arg)) {
Scm_Error("flock object required for fcntl(%s), but got %S",
flag_name(op), arg);
}
ScmSysFlock *fl = SCM_SYS_FLOCK(arg);
SCM_SYSCALL(r, fcntl(fd, op, &fl->lock));
if (op == F_SETLK) {
if (r >= 0) return SCM_TRUE;
if (errno == EAGAIN) return SCM_FALSE;
}
if (r < 0) Scm_SysError("fcntl(%s) failed", flag_name(op));
return SCM_TRUE;
default:
Scm_Error("unknown operation code (%d) for fcntl", op);
return SCM_UNDEFINED; /* dummy */
}
#else /*GAUCHE_WINDOWS*/
Scm_Error("fcntl not supported on MinGW port");
return SCM_UNDEFINED; /*dummy*/
#endif /*GAUCHE_WINDOWS*/
}
