/external/ocamllwt/src/unix/lwt_unix_unix.c
C | 2293 lines | 1785 code | 345 blank | 163 comment | 126 complexity | 2a2ffa669eea87e64db275cf4ab250dd MD5 | raw file
Possible License(s): Apache-2.0, LGPL-2.0, LGPL-2.1, MIT, WTFPL
Large files files are truncated, but you can click here to view the full file
- /* Lightweight thread library for Objective Caml
- * http://www.ocsigen.org/lwt
- * Module Lwt_unix_unix
- * Copyright (C) 2009-2010 J?r?mie Dimino
- * 2009 Mauricio Fernandez
- * 2010 Pierre Chambart
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as
- * published by the Free Software Foundation, with linking exceptions;
- * either version 2.1 of the License, or (at your option) any later
- * version. See COPYING file for details.
- *
- * This program is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
- * 02111-1307, USA.
- */
- /* Unix (non windows) version of stubs. */
- /* +-----------------------------------------------------------------+
- | Test for readability/writability |
- +-----------------------------------------------------------------+ */
- #include <poll.h>
- CAMLprim value lwt_unix_readable(value fd)
- {
- struct pollfd pollfd;
- pollfd.fd = Int_val(fd);
- pollfd.events = POLLIN;
- pollfd.revents = 0;
- if (poll(&pollfd, 1, 0) < 0)
- uerror("readable", Nothing);
- return (Val_bool(pollfd.revents & POLLIN));
- }
- CAMLprim value lwt_unix_writable(value fd)
- {
- struct pollfd pollfd;
- pollfd.fd = Int_val(fd);
- pollfd.events = POLLOUT;
- pollfd.revents = 0;
- if (poll(&pollfd, 1, 0) < 0)
- uerror("readable", Nothing);
- return (Val_bool(pollfd.revents & POLLOUT));
- }
- /* +-----------------------------------------------------------------+
- | Memory mapped files |
- +-----------------------------------------------------------------+ */
- static int advise_table[] = {
- MADV_NORMAL,
- MADV_RANDOM,
- MADV_SEQUENTIAL,
- MADV_WILLNEED,
- MADV_DONTNEED,
- };
- CAMLprim value lwt_unix_madvise (value val_buffer, value val_offset, value val_length, value val_advice)
- {
- int ret = madvise((char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset),
- Long_val(val_length),
- advise_table[Int_val(val_advice)]);
- if (ret == -1) uerror("madvise", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_get_page_size()
- {
- long page_size = sysconf(_SC_PAGESIZE);
- if (page_size < 0) page_size = 4096;
- return Val_long(page_size);
- }
- CAMLprim value lwt_unix_mincore(value val_buffer, value val_offset, value val_length, value val_states)
- {
- long len = Wosize_val(val_states);
- unsigned char vec[len];
- mincore((char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset), Long_val(val_length), vec);
- long i;
- for (i = 0; i < len; i++)
- Field(val_states, i) = Val_bool(vec[i] & 1);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | read/write |
- +-----------------------------------------------------------------+ */
- CAMLprim value lwt_unix_read(value val_fd, value val_buf, value val_ofs, value val_len)
- {
- int ret;
- ret = read(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len));
- if (ret == -1) uerror("read", Nothing);
- return Val_int(ret);
- }
- CAMLprim value lwt_unix_bytes_read(value val_fd, value val_buf, value val_ofs, value val_len)
- {
- int ret;
- ret = read(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len));
- if (ret == -1) uerror("read", Nothing);
- return Val_int(ret);
- }
- CAMLprim value lwt_unix_write(value val_fd, value val_buf, value val_ofs, value val_len)
- {
- int ret;
- ret = write(Int_val(val_fd), &Byte(String_val(val_buf), Long_val(val_ofs)), Long_val(val_len));
- if (ret == -1) uerror("write", Nothing);
- return Val_int(ret);
- }
- CAMLprim value lwt_unix_bytes_write(value val_fd, value val_buf, value val_ofs, value val_len)
- {
- int ret;
- ret = write(Int_val(val_fd), (char*)Caml_ba_array_val(val_buf)->data + Long_val(val_ofs), Long_val(val_len));
- if (ret == -1) uerror("write", Nothing);
- return Val_int(ret);
- }
- /* +-----------------------------------------------------------------+
- | recv/send |
- +-----------------------------------------------------------------+ */
- static int msg_flag_table[] = {
- MSG_OOB, MSG_DONTROUTE, MSG_PEEK
- };
- value lwt_unix_recv(value fd, value buf, value ofs, value len, value flags)
- {
- int ret;
- ret = recv(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len),
- convert_flag_list(flags, msg_flag_table));
- if (ret == -1) uerror("recv", Nothing);
- return Val_int(ret);
- }
- value lwt_unix_bytes_recv(value fd, value buf, value ofs, value len, value flags)
- {
- int ret;
- ret = recv(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len),
- convert_flag_list(flags, msg_flag_table));
- if (ret == -1) uerror("recv", Nothing);
- return Val_int(ret);
- }
- value lwt_unix_send(value fd, value buf, value ofs, value len, value flags)
- {
- int ret;
- ret = send(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len),
- convert_flag_list(flags, msg_flag_table));
- if (ret == -1) uerror("send", Nothing);
- return Val_int(ret);
- }
- value lwt_unix_bytes_send(value fd, value buf, value ofs, value len, value flags)
- {
- int ret;
- ret = send(Int_val(fd), (char*)Caml_ba_array_val(buf)->data + Long_val(ofs), Long_val(len),
- convert_flag_list(flags, msg_flag_table));
- if (ret == -1) uerror("send", Nothing);
- return Val_int(ret);
- }
- /* +-----------------------------------------------------------------+
- | recvfrom/sendto |
- +-----------------------------------------------------------------+ */
- extern int socket_domain_table[];
- extern int socket_type_table[];
- union sock_addr_union {
- struct sockaddr s_gen;
- struct sockaddr_un s_unix;
- struct sockaddr_in s_inet;
- struct sockaddr_in6 s_inet6;
- };
- CAMLexport value alloc_sockaddr (union sock_addr_union * addr /*in*/,
- socklen_t addr_len, int close_on_error);
- value lwt_unix_recvfrom(value fd, value buf, value ofs, value len, value flags)
- {
- CAMLparam5(fd, buf, ofs, len, flags);
- CAMLlocal2(result, address);
- int ret;
- union sock_addr_union addr;
- socklen_t addr_len;
- addr_len = sizeof(addr);
- ret = recvfrom(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len),
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, &addr_len);
- if (ret == -1) uerror("recvfrom", Nothing);
- address = alloc_sockaddr(&addr, addr_len, -1);
- result = caml_alloc_tuple(2);
- Field(result, 0) = Val_int(ret);
- Field(result, 1) = address;
- CAMLreturn(result);
- }
- value lwt_unix_bytes_recvfrom(value fd, value buf, value ofs, value len, value flags)
- {
- CAMLparam5(fd, buf, ofs, len, flags);
- CAMLlocal2(result, address);
- int ret;
- union sock_addr_union addr;
- socklen_t addr_len;
- addr_len = sizeof(addr);
- ret = recvfrom(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len),
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, &addr_len);
- if (ret == -1) uerror("recvfrom", Nothing);
- address = alloc_sockaddr(&addr, addr_len, -1);
- result = caml_alloc_tuple(2);
- Field(result, 0) = Val_int(ret);
- Field(result, 1) = address;
- CAMLreturn(result);
- }
- extern void get_sockaddr (value mladdr,
- union sock_addr_union * addr /*out*/,
- socklen_t * addr_len /*out*/);
- value lwt_unix_sendto(value fd, value buf, value ofs, value len, value flags, value dest)
- {
- union sock_addr_union addr;
- socklen_t addr_len;
- int ret;
- get_sockaddr(dest, &addr, &addr_len);
- ret = sendto(Int_val(fd), &Byte(String_val(buf), Long_val(ofs)), Long_val(len),
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, addr_len);
- if (ret == -1) uerror("send", Nothing);
- return Val_int(ret);
- }
- CAMLprim value lwt_unix_sendto_byte(value *argv, int argc)
- {
- return lwt_unix_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
- }
- value lwt_unix_bytes_sendto(value fd, value buf, value ofs, value len, value flags, value dest)
- {
- union sock_addr_union addr;
- socklen_t addr_len;
- int ret;
- get_sockaddr(dest, &addr, &addr_len);
- ret = sendto(Int_val(fd), (char*)Caml_ba_data_val(buf) + Long_val(ofs), Long_val(len),
- convert_flag_list(flags, msg_flag_table),
- &addr.s_gen, addr_len);
- if (ret == -1) uerror("send", Nothing);
- return Val_int(ret);
- }
- CAMLprim value lwt_unix_bytes_sendto_byte(value *argv, int argc)
- {
- return lwt_unix_bytes_sendto(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
- }
- /* +-----------------------------------------------------------------+
- | {recv/send}_msg |
- +-----------------------------------------------------------------+ */
- /* Convert a caml list of io-vectors into a C array io io-vector
- structures */
- static void store_iovs(struct iovec *iovs, value iovs_val)
- {
- CAMLparam0();
- CAMLlocal2(list, x);
- for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) {
- x = Field(list, 0);
- iovs->iov_base = &Byte(String_val(Field(x, 0)), Long_val(Field(x, 1)));
- iovs->iov_len = Long_val(Field(x, 2));
- }
- CAMLreturn0;
- }
- static void bytes_store_iovs(struct iovec *iovs, value iovs_val)
- {
- CAMLparam0();
- CAMLlocal2(list, x);
- for(list = iovs_val; Is_block(list); list = Field(list, 1), iovs++) {
- x = Field(list, 0);
- iovs->iov_base = (char*)Caml_ba_data_val(Field(x, 0)) + Long_val(Field(x, 1));
- iovs->iov_len = Long_val(Field(x, 2));
- }
- CAMLreturn0;
- }
- static value wrapper_recv_msg(int fd, int n_iovs, struct iovec *iovs)
- {
- CAMLparam0();
- CAMLlocal3(list, result, x);
- struct msghdr msg;
- memset(&msg, 0, sizeof(msg));
- msg.msg_iov = iovs;
- msg.msg_iovlen = n_iovs;
- #if defined(HAVE_FD_PASSING)
- msg.msg_controllen = CMSG_SPACE(256 * sizeof(int));
- msg.msg_control = alloca(msg.msg_controllen);
- memset(msg.msg_control, 0, msg.msg_controllen);
- #endif
- int ret = recvmsg(fd, &msg, 0);
- if (ret == -1) uerror("recv_msg", Nothing);
- list = Val_int(0);
- #if defined(HAVE_FD_PASSING)
- struct cmsghdr *cm;
- for (cm = CMSG_FIRSTHDR(&msg); cm; cm = CMSG_NXTHDR(&msg, cm))
- if (cm->cmsg_level == SOL_SOCKET && cm->cmsg_type == SCM_RIGHTS) {
- int *fds = (int*)CMSG_DATA(cm);
- int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int);
- int i;
- for(i = nfds - 1; i >= 0; i--) {
- x = caml_alloc_tuple(2);
- Store_field(x, 0, Val_int(fds[i]));
- Store_field(x, 1, list);
- list = x;
- };
- break;
- };
- #endif
- result = caml_alloc_tuple(2);
- Store_field(result, 0, Val_int(ret));
- Store_field(result, 1, list);
- CAMLreturn(result);
- }
- CAMLprim value lwt_unix_recv_msg(value val_fd, value val_n_iovs, value val_iovs)
- {
- int n_iovs = Int_val(val_n_iovs);
- struct iovec iovs[n_iovs];
- store_iovs(iovs, val_iovs);
- return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs);
- }
- CAMLprim value lwt_unix_bytes_recv_msg(value val_fd, value val_n_iovs, value val_iovs)
- {
- int n_iovs = Int_val(val_n_iovs);
- struct iovec iovs[n_iovs];
- bytes_store_iovs(iovs, val_iovs);
- return wrapper_recv_msg(Int_val(val_fd), n_iovs, iovs);
- }
- static value wrapper_send_msg(int fd, int n_iovs, struct iovec *iovs, value val_n_fds, value val_fds)
- {
- CAMLparam2(val_n_fds, val_fds);
- struct msghdr msg;
- memset(&msg, 0, sizeof(msg));
- msg.msg_iov = iovs;
- msg.msg_iovlen = n_iovs;
- #if defined(HAVE_FD_PASSING)
- int n_fds = Int_val(val_n_fds);
- if (n_fds > 0) {
- msg.msg_controllen = CMSG_SPACE(n_fds * sizeof(int));
- msg.msg_control = alloca(msg.msg_controllen);
- memset(msg.msg_control, 0, msg.msg_controllen);
- struct cmsghdr *cm;
- cm = CMSG_FIRSTHDR(&msg);
- cm->cmsg_level = SOL_SOCKET;
- cm->cmsg_type = SCM_RIGHTS;
- cm->cmsg_len = CMSG_LEN(n_fds * sizeof(int));
- int *fds = (int*)CMSG_DATA(cm);
- for(; Is_block(val_fds); val_fds = Field(val_fds, 1), fds++)
- *fds = Int_val(Field(val_fds, 0));
- };
- #else
- if (n_fds > 0) lwt_unix_not_available("fd_passing");
- #endif
- int ret = sendmsg(fd, &msg, 0);
- if (ret == -1) uerror("send_msg", Nothing);
- CAMLreturn(Val_int(ret));
- }
- CAMLprim value lwt_unix_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds)
- {
- int n_iovs = Int_val(val_n_iovs);
- struct iovec iovs[n_iovs];
- store_iovs(iovs, val_iovs);
- return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds);
- }
- CAMLprim value lwt_unix_bytes_send_msg(value val_fd, value val_n_iovs, value val_iovs, value val_n_fds, value val_fds)
- {
- int n_iovs = Int_val(val_n_iovs);
- struct iovec iovs[n_iovs];
- bytes_store_iovs(iovs, val_iovs);
- return wrapper_send_msg(Int_val(val_fd), n_iovs, iovs, val_n_fds, val_fds);
- }
- /* +-----------------------------------------------------------------+
- | Credentials |
- +-----------------------------------------------------------------+ */
- #if defined(HAVE_GET_CREDENTIALS)
- #include <sys/un.h>
- CAMLprim value lwt_unix_get_credentials(value fd)
- {
- CAMLparam1(fd);
- CAMLlocal1(res);
- struct ucred cred;
- socklen_t cred_len = sizeof(cred);
- if (getsockopt(Int_val(fd), SOL_SOCKET, SO_PEERCRED, &cred, &cred_len) == -1)
- uerror("get_credentials", Nothing);
- res = caml_alloc_tuple(3);
- Store_field(res, 0, Val_int(cred.pid));
- Store_field(res, 1, Val_int(cred.uid));
- Store_field(res, 2, Val_int(cred.gid));
- CAMLreturn(res);
- }
- #endif
- /* +-----------------------------------------------------------------+
- | wait4 |
- +-----------------------------------------------------------------+ */
- /* Some code duplicated from OCaml's otherlibs/unix/wait.c */
- #include <sys/time.h>
- #include <sys/resource.h>
- #include <sys/wait.h>
- CAMLextern int caml_convert_signal_number (int);
- CAMLextern int caml_rev_convert_signal_number (int);
- #if !(defined(WIFEXITED) && defined(WEXITSTATUS) && defined(WIFSTOPPED) && \
- defined(WSTOPSIG) && defined(WTERMSIG))
- /* Assume old-style V7 status word */
- #define WIFEXITED(status) (((status) & 0xFF) == 0)
- #define WEXITSTATUS(status) (((status) >> 8) & 0xFF)
- #define WIFSTOPPED(status) (((status) & 0xFF) == 0xFF)
- #define WSTOPSIG(status) (((status) >> 8) & 0xFF)
- #define WTERMSIG(status) ((status) & 0x3F)
- #endif
- #define TAG_WEXITED 0
- #define TAG_WSIGNALED 1
- #define TAG_WSTOPPED 2
- static value alloc_process_status(int status)
- {
- value st;
- if (WIFEXITED(status)) {
- st = alloc_small(1, TAG_WEXITED);
- Field(st, 0) = Val_int(WEXITSTATUS(status));
- }
- else if (WIFSTOPPED(status)) {
- st = alloc_small(1, TAG_WSTOPPED);
- Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
- }
- else {
- st = alloc_small(1, TAG_WSIGNALED);
- Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
- }
- return st;
- }
- static int wait_flag_table[] = {
- WNOHANG, WUNTRACED
- };
- value lwt_unix_wait4(value flags, value pid_req)
- {
- CAMLparam1(flags);
- CAMLlocal2(times, res);
- int pid, status, cv_flags;
- cv_flags = caml_convert_flag_list(flags, wait_flag_table);
- struct rusage ru;
- caml_enter_blocking_section();
- pid = wait4(Int_val(pid_req), &status, cv_flags, &ru);
- caml_leave_blocking_section();
- if (pid == -1) uerror("wait4", Nothing);
- times = alloc_small(2 * Double_wosize, Double_array_tag);
- Store_double_field(times, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
- Store_double_field(times, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
- res = caml_alloc_tuple(3);
- Store_field(res, 0, Val_int(pid));
- Store_field(res, 1, alloc_process_status(status));
- Store_field(res, 2, times);
- CAMLreturn(res);
- }
- value lwt_unix_has_wait4(value unit)
- {
- return Val_int(1);
- }
- /* +-----------------------------------------------------------------+
- | CPUs |
- +-----------------------------------------------------------------+ */
- #if defined(HAVE_GETCPU)
- CAMLprim value lwt_unix_get_cpu()
- {
- int cpu = sched_getcpu();
- if (cpu < 0) uerror("sched_getcpu", Nothing);
- return Val_int(cpu);
- }
- #endif
- #if defined(HAVE_AFFINITY)
- CAMLprim value lwt_unix_get_affinity(value val_pid)
- {
- CAMLparam1(val_pid);
- CAMLlocal2(list, node);
- cpu_set_t cpus;
- if (sched_getaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0)
- uerror("sched_getaffinity", Nothing);
- int i;
- list = Val_int(0);
- for (i = sizeof(cpu_set_t) * 8 - 1; i >= 0; i--) {
- if (CPU_ISSET(i, &cpus)) {
- node = caml_alloc_tuple(2);
- Field(node, 0) = Val_int(i);
- Field(node, 1) = list;
- list = node;
- }
- }
- CAMLreturn(list);
- }
- CAMLprim value lwt_unix_set_affinity(value val_pid, value val_cpus)
- {
- cpu_set_t cpus;
- CPU_ZERO(&cpus);
- for (; Is_block(val_cpus); val_cpus = Field(val_cpus, 1))
- CPU_SET(Int_val(Field(val_cpus, 0)), &cpus);
- if (sched_setaffinity(Int_val(val_pid), sizeof(cpu_set_t), &cpus) < 0)
- uerror("sched_setaffinity", Nothing);
- return Val_unit;
- }
- #endif
- /* +-----------------------------------------------------------------+
- | JOB: guess_blocking |
- +-----------------------------------------------------------------+ */
- struct job_guess_blocking {
- struct lwt_unix_job job;
- int fd;
- int result;
- };
- #define Job_guess_blocking_val(v) *(struct job_guess_blocking**)Data_custom_val(v)
- static void worker_guess_blocking(struct job_guess_blocking *job)
- {
- struct stat stat;
- if (fstat(job->fd, &stat) == 0)
- job->result = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode));
- else
- job->result = 1;
- }
- CAMLprim value lwt_unix_guess_blocking_job(value val_fd)
- {
- struct job_guess_blocking *job = lwt_unix_new(struct job_guess_blocking);
- job->job.worker = (lwt_unix_job_worker)worker_guess_blocking;
- job->fd = Int_val(val_fd);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_guess_blocking_result(value val_job)
- {
- struct job_guess_blocking *job = Job_guess_blocking_val(val_job);
- return Bool_val(job->result);
- }
- CAMLprim value lwt_unix_guess_blocking_free(value val_job)
- {
- struct job_guess_blocking *job = Job_guess_blocking_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: wait_mincore |
- +-----------------------------------------------------------------+ */
- struct job_wait_mincore {
- struct lwt_unix_job job;
- char *ptr;
- };
- #define Job_wait_mincore_val(v) *(struct job_wait_mincore**)Data_custom_val(v)
- static void worker_wait_mincore(struct job_wait_mincore *job)
- {
- /* Read the byte to force the kernel to fetch the page: */
- char dummy = *(job->ptr);
- /* Make the compiler happy: */
- dummy = 0;
- }
- CAMLprim value lwt_unix_wait_mincore_job(value val_buffer, value val_offset)
- {
- struct job_wait_mincore *job = lwt_unix_new(struct job_wait_mincore);
- job->job.worker = (lwt_unix_job_worker)worker_wait_mincore;
- job->ptr = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_wait_mincore_free(value val_job)
- {
- struct job_wait_mincore *job = Job_wait_mincore_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: open |
- +-----------------------------------------------------------------+ */
- #ifndef O_NONBLOCK
- #define O_NONBLOCK O_NDELAY
- #endif
- #ifndef O_DSYNC
- #define O_DSYNC 0
- #endif
- #ifndef O_SYNC
- #define O_SYNC 0
- #endif
- #ifndef O_RSYNC
- #define O_RSYNC 0
- #endif
- static int open_flag_table[] = {
- O_RDONLY,
- O_WRONLY,
- O_RDWR,
- O_NONBLOCK,
- O_APPEND,
- O_CREAT,
- O_TRUNC,
- O_EXCL,
- O_NOCTTY,
- O_DSYNC,
- O_SYNC,
- O_RSYNC
- };
- struct job_open {
- struct lwt_unix_job job;
- char *path;
- int flags;
- int perms;
- int fd;
- int blocking;
- int error_code;
- };
- #define Job_open_val(v) *(struct job_open**)Data_custom_val(v)
- static void worker_open(struct job_open *job)
- {
- int fd;
- fd = open(job->path, job->flags, job->perms);
- job->fd = fd;
- job->error_code = errno;
- if (fd >= 0) {
- struct stat stat;
- if (fstat(fd, &stat) < 0)
- job->blocking = 1;
- else
- job->blocking = !(S_ISFIFO(stat.st_mode) || S_ISSOCK(stat.st_mode));
- }
- }
- CAMLprim value lwt_unix_open_job(value val_path, value val_flags, value val_perms)
- {
- struct job_open *job = lwt_unix_new(struct job_open);
- job->job.worker = (lwt_unix_job_worker)worker_open;
- job->path = lwt_unix_strdup(String_val(val_path));
- job->flags = convert_flag_list(val_flags, open_flag_table);
- job->perms = Int_val(val_perms);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_open_result(value val_job)
- {
- struct job_open *job = Job_open_val(val_job);
- int fd = job->fd;
- if (fd < 0) unix_error(job->error_code, "open", Nothing);
- value result = caml_alloc_tuple(2);
- Field(result, 0) = Val_int(fd);
- Field(result, 1) = Val_bool(job->blocking);
- return result;
- }
- CAMLprim value lwt_unix_open_free(value val_job)
- {
- struct job_open *job = Job_open_val(val_job);
- free(job->path);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: close |
- +-----------------------------------------------------------------+ */
- struct job_close {
- struct lwt_unix_job job;
- int fd;
- int result;
- int error_code;
- };
- #define Job_close_val(v) *(struct job_close**)Data_custom_val(v)
- static void worker_close(struct job_close *job)
- {
- job->result = close(job->fd);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_close_job(value val_fd)
- {
- struct job_close *job = lwt_unix_new(struct job_close);
- job->job.worker = (lwt_unix_job_worker)worker_close;
- job->fd = Int_val(val_fd);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_close_result(value val_job)
- {
- struct job_close *job = Job_close_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "close", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_close_free(value val_job)
- {
- lwt_unix_free_job(&(Job_close_val(val_job))->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: read |
- +-----------------------------------------------------------------+ */
- struct job_read {
- struct lwt_unix_job job;
- int fd;
- char *buffer;
- int length;
- int result;
- int error_code;
- };
- #define Job_read_val(v) *(struct job_read**)Data_custom_val(v)
- static void worker_read(struct job_read *job)
- {
- job->result = read(job->fd, job->buffer, job->length);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_read_job(value val_fd, value val_length)
- {
- struct job_read *job = lwt_unix_new(struct job_read);
- long length = Long_val(val_length);
- job->job.worker = (lwt_unix_job_worker)worker_read;
- job->fd = Int_val(val_fd);
- job->buffer = (char*)lwt_unix_malloc(length);
- job->length = length;
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_read_result(value val_job, value val_string, value val_offset)
- {
- struct job_read *job = Job_read_val(val_job);
- int result = job->result;
- if (result < 0) unix_error(job->error_code, "read", Nothing);
- memcpy(String_val(val_string) + Long_val(val_offset), job->buffer, result);
- return Val_long(result);
- }
- CAMLprim value lwt_unix_read_free(value val_job)
- {
- struct job_read *job = Job_read_val(val_job);
- free(job->buffer);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: bytes_read |
- +-----------------------------------------------------------------+ */
- struct job_bytes_read {
- struct lwt_unix_job job;
- int fd;
- char *buffer;
- int length;
- int result;
- int error_code;
- };
- #define Job_bytes_read_val(v) *(struct job_bytes_read**)Data_custom_val(v)
- static void worker_bytes_read(struct job_bytes_read *job)
- {
- job->result = read(job->fd, job->buffer, job->length);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_bytes_read_job(value val_fd, value val_buf, value val_ofs, value val_len)
- {
- struct job_bytes_read *job = lwt_unix_new(struct job_bytes_read);
- job->job.worker = (lwt_unix_job_worker)worker_bytes_read;
- job->fd = Int_val(val_fd);
- job->buffer = (char*)Caml_ba_data_val(val_buf) + Long_val(val_ofs);
- job->length = Long_val(val_len);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_bytes_read_result(value val_job)
- {
- struct job_bytes_read *job = Job_bytes_read_val(val_job);
- int result = job->result;
- if (result < 0) unix_error(job->error_code, "read", Nothing);
- return Val_long(result);
- }
- CAMLprim value lwt_unix_bytes_read_free(value val_job)
- {
- struct job_bytes_read *job = Job_bytes_read_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: write |
- +-----------------------------------------------------------------+ */
- struct job_write {
- struct lwt_unix_job job;
- int fd;
- char *buffer;
- int length;
- int result;
- int error_code;
- };
- #define Job_write_val(v) *(struct job_write**)Data_custom_val(v)
- static void worker_write(struct job_write *job)
- {
- job->result = write(job->fd, job->buffer, job->length);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_write_job(value val_fd, value val_string, value val_offset, value val_length)
- {
- struct job_write *job = lwt_unix_new(struct job_write);
- long length = Long_val(val_length);
- job->job.worker = (lwt_unix_job_worker)worker_write;
- job->fd = Int_val(val_fd);
- job->buffer = (char*)lwt_unix_malloc(length);
- memcpy(job->buffer, String_val(val_string) + Long_val(val_offset), length);
- job->length = length;
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_write_result(value val_job)
- {
- struct job_write *job = Job_write_val(val_job);
- int result = job->result;
- if (result < 0) unix_error(job->error_code, "write", Nothing);
- return Val_long(result);
- }
- CAMLprim value lwt_unix_write_free(value val_job)
- {
- struct job_write *job = Job_write_val(val_job);
- free(job->buffer);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: bytes_write |
- +-----------------------------------------------------------------+ */
- struct job_bytes_write {
- struct lwt_unix_job job;
- int fd;
- char *buffer;
- int length;
- int result;
- int error_code;
- };
- #define Job_bytes_write_val(v) *(struct job_bytes_write**)Data_custom_val(v)
- static void worker_bytes_write(struct job_bytes_write *job)
- {
- job->result = write(job->fd, job->buffer, job->length);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_bytes_write_job(value val_fd, value val_buffer, value val_offset, value val_length)
- {
- struct job_bytes_write *job = lwt_unix_new(struct job_bytes_write);
- job->job.worker = (lwt_unix_job_worker)worker_bytes_write;
- job->fd = Int_val(val_fd);
- job->buffer = (char*)Caml_ba_data_val(val_buffer) + Long_val(val_offset);
- job->length = Long_val(val_length);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_bytes_write_result(value val_job)
- {
- struct job_bytes_write *job = Job_bytes_write_val(val_job);
- int result = job->result;
- if (result < 0) unix_error(job->error_code, "write", Nothing);
- return Val_long(result);
- }
- CAMLprim value lwt_unix_bytes_write_free(value val_job)
- {
- struct job_bytes_write *job = Job_bytes_write_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: lseek |
- +-----------------------------------------------------------------+ */
- struct job_lseek {
- struct lwt_unix_job job;
- int fd;
- off_t offset;
- int command;
- off_t result;
- int error_code;
- };
- #define Job_lseek_val(v) *(struct job_lseek**)Data_custom_val(v)
- static int seek_command_table[] = {
- SEEK_SET, SEEK_CUR, SEEK_END
- };
- static void worker_lseek(struct job_lseek *job)
- {
- job->result = lseek(job->fd, job->offset, job->command);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_lseek_job(value val_fd, value val_offset, value val_command)
- {
- struct job_lseek *job = lwt_unix_new(struct job_lseek);
- job->job.worker = (lwt_unix_job_worker)worker_lseek;
- job->fd = Int_val(val_fd);
- job->offset = Long_val(val_offset);
- job->command = seek_command_table[Int_val(val_command)];
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_lseek_result(value val_job)
- {
- struct job_lseek *job = Job_lseek_val(val_job);
- off_t result = job->result;
- if (result < 0) unix_error(job->error_code, "lseek", Nothing);
- return Val_long(result);
- }
- CAMLprim value lwt_unix_lseek_free(value val_job)
- {
- struct job_lseek *job = Job_lseek_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- CAMLprim value lwt_unix_lseek_64_job(value val_fd, value val_offset, value val_command)
- {
- struct job_lseek *job = lwt_unix_new(struct job_lseek);
- job->job.worker = (lwt_unix_job_worker)worker_lseek;
- job->fd = Int_val(val_fd);
- job->offset = Int64_val(val_offset);
- job->command = seek_command_table[Int_val(val_command)];
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_lseek_64_result(value val_job)
- {
- struct job_lseek *job = Job_lseek_val(val_job);
- off_t result = job->result;
- if (result < 0) unix_error(job->error_code, "lseek", Nothing);
- return caml_copy_int64(result);
- }
- CAMLprim value lwt_unix_lseek_64_free(value val_job)
- {
- struct job_lseek *job = Job_lseek_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: truncate |
- +-----------------------------------------------------------------+ */
- struct job_truncate {
- struct lwt_unix_job job;
- char *name;
- off_t offset;
- int result;
- int error_code;
- };
- #define Job_truncate_val(v) *(struct job_truncate**)Data_custom_val(v)
- static void worker_truncate(struct job_truncate *job)
- {
- job->result = truncate(job->name, job->offset);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_truncate_job(value val_name, value val_offset)
- {
- struct job_truncate *job = lwt_unix_new(struct job_truncate);
- job->job.worker = (lwt_unix_job_worker)worker_truncate;
- job->name = lwt_unix_strdup(String_val(val_name));
- job->offset = Long_val(val_offset);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_truncate_result(value val_job)
- {
- struct job_truncate *job = Job_truncate_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "truncate", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_truncate_free(value val_job)
- {
- struct job_truncate *job = Job_truncate_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- CAMLprim value lwt_unix_truncate_64_job(value val_name, value val_offset)
- {
- struct job_truncate *job = lwt_unix_new(struct job_truncate);
- job->job.worker = (lwt_unix_job_worker)worker_truncate;
- job->name = lwt_unix_strdup(String_val(val_name));
- job->offset = Int64_val(val_offset);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_truncate_64_result(value val_job)
- {
- struct job_truncate *job = Job_truncate_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "truncate", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_truncate_64_free(value val_job)
- {
- struct job_truncate *job = Job_truncate_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: ftruncate |
- +-----------------------------------------------------------------+ */
- struct job_ftruncate {
- struct lwt_unix_job job;
- int fd;
- off_t offset;
- int result;
- int error_code;
- };
- #define Job_ftruncate_val(v) *(struct job_ftruncate**)Data_custom_val(v)
- static void worker_ftruncate(struct job_ftruncate *job)
- {
- job->result = ftruncate(job->fd, job->offset);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_ftruncate_job(value val_fd, value val_offset)
- {
- struct job_ftruncate *job = lwt_unix_new(struct job_ftruncate);
- job->job.worker = (lwt_unix_job_worker)worker_ftruncate;
- job->fd = Int_val(val_fd);
- job->offset = Long_val(val_offset);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_ftruncate_result(value val_job)
- {
- struct job_ftruncate *job = Job_ftruncate_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "ftruncate", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_ftruncate_free(value val_job)
- {
- struct job_ftruncate *job = Job_ftruncate_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- CAMLprim value lwt_unix_ftruncate_64_job(value val_fd, value val_offset)
- {
- struct job_ftruncate *job = lwt_unix_new(struct job_ftruncate);
- job->job.worker = (lwt_unix_job_worker)worker_ftruncate;
- job->fd = Int_val(val_fd);
- job->offset = Int64_val(val_offset);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_ftruncate_64_result(value val_job)
- {
- struct job_ftruncate *job = Job_ftruncate_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "ftruncate", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_ftruncate_64_free(value val_job)
- {
- struct job_ftruncate *job = Job_ftruncate_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: stat |
- +-----------------------------------------------------------------+ */
- struct job_stat {
- struct lwt_unix_job job;
- char *name;
- struct stat stat;
- int result;
- int error_code;
- };
- #define Job_stat_val(v) *(struct job_stat**)Data_custom_val(v)
- static value copy_stat(int use_64, struct stat *buf)
- {
- CAMLparam0();
- CAMLlocal5(atime, mtime, ctime, offset, v);
- atime = copy_double((double) buf->st_atime);
- mtime = copy_double((double) buf->st_mtime);
- ctime = copy_double((double) buf->st_ctime);
- offset = use_64 ? caml_copy_int64(buf->st_size) : Val_int(buf->st_size);
- v = alloc_small(12, 0);
- Field(v, 0) = Val_int (buf->st_dev);
- Field(v, 1) = Val_int (buf->st_ino);
- switch (buf->st_mode & S_IFMT) {
- case S_IFREG:
- Field(v, 2) = Val_int(0);
- break;
- case S_IFDIR:
- Field(v, 2) = Val_int(1);
- break;
- case S_IFCHR:
- Field(v, 2) = Val_int(2);
- break;
- case S_IFBLK:
- Field(v, 2) = Val_int(3);
- break;
- case S_IFLNK:
- Field(v, 2) = Val_int(4);
- break;
- case S_IFIFO:
- Field(v, 2) = Val_int(5);
- break;
- case S_IFSOCK:
- Field(v, 2) = Val_int(6);
- break;
- default:
- Field(v, 2) = Val_int(0);
- break;
- }
- Field(v, 3) = Val_int(buf->st_mode & 07777);
- Field(v, 4) = Val_int(buf->st_nlink);
- Field(v, 5) = Val_int(buf->st_uid);
- Field(v, 6) = Val_int(buf->st_gid);
- Field(v, 7) = Val_int(buf->st_rdev);
- Field(v, 8) = offset;
- Field(v, 9) = atime;
- Field(v, 10) = mtime;
- Field(v, 11) = ctime;
- CAMLreturn(v);
- }
- static void worker_stat(struct job_stat *job)
- {
- job->result = stat(job->name, &(job->stat));
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_stat_job(value val_name)
- {
- struct job_stat *job = lwt_unix_new(struct job_stat);
- job->job.worker = (lwt_unix_job_worker)worker_stat;
- job->name = lwt_unix_strdup(String_val(val_name));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_stat_result(value val_job)
- {
- struct job_stat *job = Job_stat_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "stat", Nothing);
- return copy_stat(0, &(job->stat));
- }
- CAMLprim value lwt_unix_stat_free(value val_job)
- {
- struct job_stat *job = Job_stat_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- CAMLprim value lwt_unix_stat_64_job(value val_name)
- {
- struct job_stat *job = lwt_unix_new(struct job_stat);
- job->job.worker = (lwt_unix_job_worker)worker_stat;
- job->name = lwt_unix_strdup(String_val(val_name));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_stat_64_result(value val_job)
- {
- struct job_stat *job = Job_stat_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "stat", Nothing);
- return copy_stat(1, &(job->stat));
- }
- CAMLprim value lwt_unix_stat_64_free(value val_job)
- {
- struct job_stat *job = Job_stat_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: lstat |
- +-----------------------------------------------------------------+ */
- struct job_lstat {
- struct lwt_unix_job job;
- char *name;
- struct stat lstat;
- int result;
- int error_code;
- };
- #define Job_lstat_val(v) *(struct job_lstat**)Data_custom_val(v)
- static void worker_lstat(struct job_lstat *job)
- {
- job->result = lstat(job->name, &(job->lstat));
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_lstat_job(value val_name)
- {
- struct job_lstat *job = lwt_unix_new(struct job_lstat);
- job->job.worker = (lwt_unix_job_worker)worker_lstat;
- job->name = lwt_unix_strdup(String_val(val_name));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_lstat_result(value val_job)
- {
- struct job_lstat *job = Job_lstat_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "lstat", Nothing);
- return copy_stat(0, &(job->lstat));
- }
- CAMLprim value lwt_unix_lstat_free(value val_job)
- {
- struct job_lstat *job = Job_lstat_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- CAMLprim value lwt_unix_lstat_64_job(value val_name)
- {
- struct job_lstat *job = lwt_unix_new(struct job_lstat);
- job->job.worker = (lwt_unix_job_worker)worker_lstat;
- job->name = lwt_unix_strdup(String_val(val_name));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_lstat_64_result(value val_job)
- {
- struct job_lstat *job = Job_lstat_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "lstat", Nothing);
- return copy_stat(1, &(job->lstat));
- }
- CAMLprim value lwt_unix_lstat_64_free(value val_job)
- {
- struct job_lstat *job = Job_lstat_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: fstat |
- +-----------------------------------------------------------------+ */
- struct job_fstat {
- struct lwt_unix_job job;
- int fd;
- struct stat fstat;
- int result;
- int error_code;
- };
- #define Job_fstat_val(v) *(struct job_fstat**)Data_custom_val(v)
- static void worker_fstat(struct job_fstat *job)
- {
- job->result = fstat(job->fd, &(job->fstat));
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_fstat_job(value val_fd)
- {
- struct job_fstat *job = lwt_unix_new(struct job_fstat);
- job->job.worker = (lwt_unix_job_worker)worker_fstat;
- job->fd = Int_val(val_fd);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_fstat_result(value val_job)
- {
- struct job_fstat *job = Job_fstat_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "fstat", Nothing);
- return copy_stat(0, &(job->fstat));
- }
- CAMLprim value lwt_unix_fstat_free(value val_job)
- {
- struct job_fstat *job = Job_fstat_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- CAMLprim value lwt_unix_fstat_64_job(value val_fd)
- {
- struct job_fstat *job = lwt_unix_new(struct job_fstat);
- job->job.worker = (lwt_unix_job_worker)worker_fstat;
- job->fd = Int_val(val_fd);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_fstat_64_result(value val_job)
- {
- struct job_fstat *job = Job_fstat_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "fstat", Nothing);
- return copy_stat(1, &(job->fstat));
- }
- CAMLprim value lwt_unix_fstat_64_free(value val_job)
- {
- struct job_fstat *job = Job_fstat_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: isatty |
- +-----------------------------------------------------------------+ */
- struct job_isatty {
- struct lwt_unix_job job;
- int fd;
- int result;
- };
- #define Job_isatty_val(v) *(struct job_isatty**)Data_custom_val(v)
- static void worker_isatty(struct job_isatty *job)
- {
- job->result = isatty(job->fd);
- }
- CAMLprim value lwt_unix_isatty_job(value val_fd)
- {
- struct job_isatty *job = lwt_unix_new(struct job_isatty);
- job->job.worker = (lwt_unix_job_worker)worker_isatty;
- job->fd = Int_val(val_fd);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_isatty_result(value val_job)
- {
- struct job_isatty *job = Job_isatty_val(val_job);
- return Val_bool(job->result);
- }
- CAMLprim value lwt_unix_isatty_free(value val_job)
- {
- struct job_isatty *job = Job_isatty_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: unlink |
- +-----------------------------------------------------------------+ */
- struct job_unlink {
- struct lwt_unix_job job;
- char *name;
- int result;
- int error_code;
- };
- #define Job_unlink_val(v) *(struct job_unlink**)Data_custom_val(v)
- static void worker_unlink(struct job_unlink *job)
- {
- job->result = unlink(job->name);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_unlink_job(value val_name)
- {
- struct job_unlink *job = lwt_unix_new(struct job_unlink);
- job->job.worker = (lwt_unix_job_worker)worker_unlink;
- job->name = lwt_unix_strdup(String_val(val_name));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_unlink_result(value val_job)
- {
- struct job_unlink *job = Job_unlink_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "unlink", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_unlink_free(value val_job)
- {
- struct job_unlink *job = Job_unlink_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: rename |
- +-----------------------------------------------------------------+ */
- struct job_rename {
- struct lwt_unix_job job;
- char *name1;
- char *name2;
- int result;
- int error_code;
- };
- #define Job_rename_val(v) *(struct job_rename**)Data_custom_val(v)
- static void worker_rename(struct job_rename *job)
- {
- job->result = rename(job->name1, job->name2);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_rename_job(value val_name1, value val_name2)
- {
- struct job_rename *job = lwt_unix_new(struct job_rename);
- job->job.worker = (lwt_unix_job_worker)worker_rename;
- job->name1 = lwt_unix_strdup(String_val(val_name1));
- job->name2 = lwt_unix_strdup(String_val(val_name2));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_rename_result(value val_job)
- {
- struct job_rename *job = Job_rename_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "rename", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_rename_free(value val_job)
- {
- struct job_rename *job = Job_rename_val(val_job);
- free(job->name1);
- free(job->name2);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: link |
- +-----------------------------------------------------------------+ */
- struct job_link {
- struct lwt_unix_job job;
- char *name1;
- char *name2;
- int result;
- int error_code;
- };
- #define Job_link_val(v) *(struct job_link**)Data_custom_val(v)
- static void worker_link(struct job_link *job)
- {
- job->result = link(job->name1, job->name2);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_link_job(value val_name1, value val_name2)
- {
- struct job_link *job = lwt_unix_new(struct job_link);
- job->job.worker = (lwt_unix_job_worker)worker_link;
- job->name1 = lwt_unix_strdup(String_val(val_name1));
- job->name2 = lwt_unix_strdup(String_val(val_name2));
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_link_result(value val_job)
- {
- struct job_link *job = Job_link_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "link", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_link_free(value val_job)
- {
- struct job_link *job = Job_link_val(val_job);
- free(job->name1);
- free(job->name2);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: chmod |
- +-----------------------------------------------------------------+ */
- struct job_chmod {
- struct lwt_unix_job job;
- char *name;
- int perms;
- int result;
- int error_code;
- };
- #define Job_chmod_val(v) *(struct job_chmod**)Data_custom_val(v)
- static void worker_chmod(struct job_chmod *job)
- {
- job->result = chmod(job->name, job->perms);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_chmod_job(value val_name, value val_perms)
- {
- struct job_chmod *job = lwt_unix_new(struct job_chmod);
- job->job.worker = (lwt_unix_job_worker)worker_chmod;
- job->name = lwt_unix_strdup(String_val(val_name));
- job->perms = Int_val(val_perms);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_chmod_result(value val_job)
- {
- struct job_chmod *job = Job_chmod_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "chmod", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_chmod_free(value val_job)
- {
- struct job_chmod *job = Job_chmod_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: fchmod |
- +-----------------------------------------------------------------+ */
- struct job_fchmod {
- struct lwt_unix_job job;
- int fd;
- int perms;
- int result;
- int error_code;
- };
- #define Job_fchmod_val(v) *(struct job_fchmod**)Data_custom_val(v)
- static void worker_fchmod(struct job_fchmod *job)
- {
- job->result = fchmod(job->fd, job->perms);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_fchmod_job(value val_fd, value val_perms)
- {
- struct job_fchmod *job = lwt_unix_new(struct job_fchmod);
- job->job.worker = (lwt_unix_job_worker)worker_fchmod;
- job->fd = Int_val(val_fd);
- job->perms = Int_val(val_perms);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_fchmod_result(value val_job)
- {
- struct job_fchmod *job = Job_fchmod_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "fchmod", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_fchmod_free(value val_job)
- {
- struct job_fchmod *job = Job_fchmod_val(val_job);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: chown |
- +-----------------------------------------------------------------+ */
- struct job_chown {
- struct lwt_unix_job job;
- char *name;
- int uid;
- int gid;
- int result;
- int error_code;
- };
- #define Job_chown_val(v) *(struct job_chown**)Data_custom_val(v)
- static void worker_chown(struct job_chown *job)
- {
- job->result = chown(job->name, job->uid, job->gid);
- job->error_code = errno;
- }
- CAMLprim value lwt_unix_chown_job(value val_name, value val_uid, value val_gid)
- {
- struct job_chown *job = lwt_unix_new(struct job_chown);
- job->job.worker = (lwt_unix_job_worker)worker_chown;
- job->name = lwt_unix_strdup(String_val(val_name));
- job->uid = Int_val(val_uid);
- job->gid = Int_val(val_gid);
- return lwt_unix_alloc_job(&(job->job));
- }
- CAMLprim value lwt_unix_chown_result(value val_job)
- {
- struct job_chown *job = Job_chown_val(val_job);
- if (job->result < 0) unix_error(job->error_code, "chown", Nothing);
- return Val_unit;
- }
- CAMLprim value lwt_unix_chown_free(value val_job)
- {
- struct job_chown *job = Job_chown_val(val_job);
- free(job->name);
- lwt_unix_free_job(&job->job);
- return Val_unit;
- }
- /* +-----------------------------------------------------------------+
- | JOB: fchown |
- +-----------------------------------------------------------------+ */
- struct job_fchown {
- struct lwt_unix_job job;
- int fd;
- int uid;
- int gid;
- int result;
- int error_code;
- };
- #define Job_fchown_val(v) *(struct job_fchown**)Data_c…
Large files files are truncated, but you can click here to view the full file