1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398
|
/***********************************************************************/
/* */
/* OCaml */
/* */
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License, with */
/* the special exception on linking described in file ../LICENSE. */
/* */
/***********************************************************************/
/* Basic system calls */
#include <errno.h>
#include <fcntl.h>
#include <signal.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <time.h>
#include <sys/types.h>
#include <sys/stat.h>
#if !_WIN32
#include <sys/wait.h>
#endif
#include "config.h"
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
#ifdef HAS_TIMES
#include <sys/times.h>
#endif
#ifdef HAS_GETRUSAGE
#include <sys/time.h>
#include <sys/resource.h>
#endif
#ifdef HAS_GETTIMEOFDAY
#include <sys/time.h>
#endif
#include "alloc.h"
#include "debugger.h"
#include "fail.h"
#include "instruct.h"
#include "mlvalues.h"
#include "osdeps.h"
#include "signals.h"
#include "stacks.h"
#include "sys.h"
static char * error_message(void)
{
return strerror(errno);
}
#ifndef EAGAIN
#define EAGAIN (-1)
#endif
#ifndef EWOULDBLOCK
#define EWOULDBLOCK (-1)
#endif
CAMLexport void caml_sys_error(value arg)
{
CAMLparam1 (arg);
char * err;
CAMLlocal1 (str);
err = error_message();
if (arg == NO_ARG) {
str = caml_copy_string(err);
} else {
int err_len = strlen(err);
int arg_len = caml_string_length(arg);
str = caml_alloc_string(arg_len + 2 + err_len);
memmove(&Byte(str, 0), String_val(arg), arg_len);
memmove(&Byte(str, arg_len), ": ", 2);
memmove(&Byte(str, arg_len + 2), err, err_len);
}
caml_raise_sys_error(str);
CAMLnoreturn;
}
CAMLexport void caml_sys_io_error(value arg)
{
if (errno == EAGAIN || errno == EWOULDBLOCK) {
caml_raise_sys_blocked_io();
} else {
caml_sys_error(arg);
}
}
CAMLprim value caml_sys_exit(value retcode)
{
#ifndef NATIVE_CODE
caml_debugger(PROGRAM_EXIT);
#endif
exit(Int_val(retcode));
return Val_unit;
}
#ifndef O_BINARY
#define O_BINARY 0
#endif
#ifndef O_TEXT
#define O_TEXT 0
#endif
#ifndef O_NONBLOCK
#ifdef O_NDELAY
#define O_NONBLOCK O_NDELAY
#else
#define O_NONBLOCK 0
#endif
#endif
static int sys_open_flags[] = {
O_RDONLY, O_WRONLY, O_APPEND | O_WRONLY, O_CREAT, O_TRUNC, O_EXCL,
O_BINARY, O_TEXT, O_NONBLOCK
};
CAMLprim value caml_sys_open(value path, value vflags, value vperm)
{
CAMLparam3(path, vflags, vperm);
int fd, flags, perm;
char * p;
p = caml_stat_alloc(caml_string_length(path) + 1);
strcpy(p, String_val(path));
flags = caml_convert_flag_list(vflags, sys_open_flags);
perm = Int_val(vperm);
/* open on a named FIFO can block (PR#1533) */
caml_enter_blocking_section();
fd = open(p, flags, perm);
/* fcntl on a fd can block (PR#5069)*/
#if defined(F_SETFD) && defined(FD_CLOEXEC)
if (fd != -1)
fcntl(fd, F_SETFD, FD_CLOEXEC);
#endif
caml_leave_blocking_section();
caml_stat_free(p);
if (fd == -1) caml_sys_error(path);
CAMLreturn(Val_long(fd));
}
CAMLprim value caml_sys_close(value fd)
{
close(Int_val(fd));
return Val_unit;
}
CAMLprim value caml_sys_file_exists(value name)
{
struct stat st;
return Val_bool(stat(String_val(name), &st) == 0);
}
CAMLprim value caml_sys_is_directory(value name)
{
struct stat st;
if (stat(String_val(name), &st) == -1) caml_sys_error(name);
#ifdef S_ISDIR
return Val_bool(S_ISDIR(st.st_mode));
#else
return Val_bool(st.st_mode & S_IFDIR);
#endif
}
CAMLprim value caml_sys_remove(value name)
{
int ret;
ret = unlink(String_val(name));
if (ret != 0) caml_sys_error(name);
return Val_unit;
}
CAMLprim value caml_sys_rename(value oldname, value newname)
{
if (rename(String_val(oldname), String_val(newname)) != 0)
caml_sys_error(NO_ARG);
return Val_unit;
}
CAMLprim value caml_sys_chdir(value dirname)
{
if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname);
return Val_unit;
}
CAMLprim value caml_sys_getcwd(value unit)
{
char buff[4096];
#ifdef HAS_GETCWD
if (getcwd(buff, sizeof(buff)) == 0) caml_sys_error(NO_ARG);
#else
if (getwd(buff) == 0) caml_sys_error(NO_ARG);
#endif /* HAS_GETCWD */
return caml_copy_string(buff);
}
CAMLprim value caml_sys_getenv(value var)
{
char * res;
res = getenv(String_val(var));
if (res == 0) caml_raise_not_found();
return caml_copy_string(res);
}
char * caml_exe_name;
static char ** caml_main_argv;
CAMLprim value caml_sys_get_argv(value unit)
{
CAMLparam0 (); /* unit is unused */
CAMLlocal3 (exe_name, argv, res);
exe_name = caml_copy_string(caml_exe_name);
argv = caml_copy_string_array((char const **) caml_main_argv);
res = caml_alloc_small(2, 0);
Field(res, 0) = exe_name;
Field(res, 1) = argv;
CAMLreturn(res);
}
void caml_sys_init(char * exe_name, char **argv)
{
caml_exe_name = exe_name;
caml_main_argv = argv;
}
#ifdef _WIN32
#define WIFEXITED(status) 1
#define WEXITSTATUS(status) (status)
#else
#if !(defined(WIFEXITED) && defined(WEXITSTATUS))
/* Assume old-style V7 status word */
#define WIFEXITED(status) (((status) & 0xFF) == 0)
#define WEXITSTATUS(status) (((status) >> 8) & 0xFF)
#endif
#endif
CAMLprim value caml_sys_system_command(value command)
{
CAMLparam1 (command);
int status, retcode;
char *buf;
intnat len;
len = caml_string_length (command);
buf = caml_stat_alloc (len + 1);
memmove (buf, String_val (command), len + 1);
caml_enter_blocking_section ();
status = system(buf);
caml_leave_blocking_section ();
caml_stat_free(buf);
if (status == -1) caml_sys_error(command);
if (WIFEXITED(status))
retcode = WEXITSTATUS(status);
else
retcode = 255;
CAMLreturn (Val_int(retcode));
}
CAMLprim value caml_sys_time(value unit)
{
#ifdef HAS_GETRUSAGE
struct rusage ru;
getrusage (RUSAGE_SELF, &ru);
return caml_copy_double (ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
+ ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
#else
#ifdef HAS_TIMES
#ifndef CLK_TCK
#ifdef HZ
#define CLK_TCK HZ
#else
#define CLK_TCK 60
#endif
#endif
struct tms t;
times(&t);
return caml_copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK);
#else
/* clock() is standard ANSI C */
return caml_copy_double((double)clock() / CLOCKS_PER_SEC);
#endif
#endif
}
#ifdef _WIN32
extern int caml_win32_random_seed (intnat data[16]);
#endif
CAMLprim value caml_sys_random_seed (value unit)
{
intnat data[16];
int n, i;
value res;
#ifdef _WIN32
n = caml_win32_random_seed(data);
#else
int fd;
n = 0;
/* Try /dev/urandom first */
fd = open("/dev/urandom", O_RDONLY, 0);
if (fd != -1) {
unsigned char buffer[12];
int nread = read(fd, buffer, 12);
close(fd);
while (nread > 0) data[n++] = buffer[--nread];
}
/* If the read from /dev/urandom fully succeeded, we now have 96 bits
of good random data and can stop here. Otherwise, complement
whatever we got (probably nothing) with some not-very-random data. */
if (n < 12) {
#ifdef HAS_GETTIMEOFDAY
struct timeval tv;
gettimeofday(&tv, NULL);
data[n++] = tv.tv_usec;
data[n++] = tv.tv_sec;
#else
data[n++] = time(NULL);
#endif
#ifdef HAS_UNISTD
data[n++] = getpid();
data[n++] = getppid();
#endif
}
#endif
/* Convert to an OCaml array of ints */
res = caml_alloc_small(n, 0);
for (i = 0; i < n; i++) Field(res, i) = Val_long(data[i]);
return res;
}
CAMLprim value caml_sys_const_big_endian(value unit)
{
#ifdef ARCH_BIG_ENDIAN
return Val_true;
#else
return Val_false;
#endif
}
CAMLprim value caml_sys_const_word_size(value unit)
{
return Val_long(8 * sizeof(value));
}
CAMLprim value caml_sys_const_ostype_unix(value unit)
{
return Val_long(0 == strcmp(OCAML_OS_TYPE,"Unix"));
}
CAMLprim value caml_sys_const_ostype_win32(value unit)
{
return Val_long(0 == strcmp(OCAML_OS_TYPE,"Win32"));
}
CAMLprim value caml_sys_const_ostype_cygwin(value unit)
{
return Val_long(0 == strcmp(OCAML_OS_TYPE,"Cygwin"));
}
CAMLprim value caml_sys_get_config(value unit)
{
CAMLparam0 (); /* unit is unused */
CAMLlocal2 (result, ostype);
ostype = caml_copy_string(OCAML_OS_TYPE);
result = caml_alloc_small (3, 0);
Field(result, 0) = ostype;
Field(result, 1) = Val_long (8 * sizeof(value));
#ifdef ARCH_BIG_ENDIAN
Field(result, 2) = Val_true;
#else
Field(result, 2) = Val_false;
#endif
CAMLreturn (result);
}
CAMLprim value caml_sys_read_directory(value path)
{
CAMLparam1(path);
CAMLlocal1(result);
struct ext_table tbl;
caml_ext_table_init(&tbl, 50);
if (caml_read_directory(String_val(path), &tbl) == -1){
caml_ext_table_free(&tbl, 1);
caml_sys_error(path);
}
caml_ext_table_add(&tbl, NULL);
result = caml_copy_string_array((char const **) tbl.contents);
caml_ext_table_free(&tbl, 1);
CAMLreturn(result);
}
|