1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Basic system calls */
19
20 #include <errno.h>
21 #include <fcntl.h>
22 #include <signal.h>
23 #include <stdlib.h>
24 #include <stdio.h>
25 #include <string.h>
26 #include <time.h>
27 #include <sys/types.h>
28 #include <sys/stat.h>
29 #ifdef _WIN32
30 #include <direct.h> /* for _wchdir and _wgetcwd */
31 #else
32 #include <sys/wait.h>
33 #endif
34 #include "caml/config.h"
35 #ifdef HAS_UNISTD
36 #include <unistd.h>
37 #endif
38 #ifdef HAS_TIMES
39 #include <sys/times.h>
40 #endif
41 #ifdef HAS_GETRUSAGE
42 #include <sys/time.h>
43 #include <sys/resource.h>
44 #endif
45 #ifdef HAS_GETTIMEOFDAY
46 #include <sys/time.h>
47 #endif
48 #include "caml/alloc.h"
49 #include "caml/debugger.h"
50 #include "caml/fail.h"
51 #include "caml/gc_ctrl.h"
52 #include "caml/io.h"
53 #include "caml/misc.h"
54 #include "caml/mlvalues.h"
55 #include "caml/osdeps.h"
56 #include "caml/signals.h"
57 #include "caml/stacks.h"
58 #include "caml/sys.h"
59 #include "caml/version.h"
60 #include "caml/callback.h"
61 #include "caml/startup_aux.h"
62
63 static char * error_message(void)
64 {
65 return strerror(errno);
66 }
67
68 #ifndef EAGAIN
69 #define EAGAIN (-1)
70 #endif
71 #ifndef EWOULDBLOCK
72 #define EWOULDBLOCK (-1)
73 #endif
74
75 CAMLexport void caml_sys_error(value arg)
76 {
77 CAMLparam1 (arg);
78 char * err;
79 CAMLlocal1 (str);
80
81 err = error_message();
82 if (arg == NO_ARG) {
83 str = caml_copy_string(err);
84 } else {
85 mlsize_t err_len = strlen(err);
86 mlsize_t arg_len = caml_string_length(arg);
87 str = caml_alloc_string(arg_len + 2 + err_len);
88 memmove(&Byte(str, 0), String_val(arg), arg_len);
89 memmove(&Byte(str, arg_len), ": ", 2);
90 memmove(&Byte(str, arg_len + 2), err, err_len);
91 }
92 caml_raise_sys_error(str);
93 CAMLnoreturn;
94 }
95
96 CAMLexport void caml_sys_io_error(value arg)
97 {
98 if (errno == EAGAIN || errno == EWOULDBLOCK) {
99 caml_raise_sys_blocked_io();
100 } else {
101 caml_sys_error(arg);
102 }
103 }
104
105 /* Check that [name] can safely be used as a file path */
106
107 static void caml_sys_check_path(value name)
108 {
109 if (! caml_string_is_c_safe(name)) {
110 errno = ENOENT;
111 caml_sys_error(name);
112 }
113 }
114
115 CAMLprim value caml_sys_exit(value retcode_v)
116 {
117 int retcode = Int_val(retcode_v);
118
119 if ((caml_verb_gc & 0x400) != 0) {
120 /* cf caml_gc_counters */
121 double minwords = Caml_state->stat_minor_words
122 + (double) (Caml_state->young_end - Caml_state->young_ptr);
123 double prowords = Caml_state->stat_promoted_words;
124 double majwords =
125 Caml_state->stat_major_words + (double) caml_allocated_words;
126 double allocated_words = minwords + majwords - prowords;
127 intnat mincoll = Caml_state->stat_minor_collections;
128 intnat majcoll = Caml_state->stat_major_collections;
129 intnat heap_words = Caml_state->stat_heap_wsz;
130 intnat heap_chunks = Caml_state->stat_heap_chunks;
131 intnat top_heap_words = Caml_state->stat_top_heap_wsz;
132 intnat cpct = Caml_state->stat_compactions;
133 caml_gc_message(0x400, "allocated_words: %.0f\n", allocated_words);
134 caml_gc_message(0x400, "minor_words: %.0f\n", minwords);
135 caml_gc_message(0x400, "promoted_words: %.0f\n", prowords);
136 caml_gc_message(0x400, "major_words: %.0f\n", majwords);
137 caml_gc_message(0x400, "minor_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
138 mincoll);
139 caml_gc_message(0x400, "major_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
140 majcoll);
141 caml_gc_message(0x400, "heap_words: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
142 heap_words);
143 caml_gc_message(0x400, "heap_chunks: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
144 heap_chunks);
145 caml_gc_message(0x400, "top_heap_words: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
146 top_heap_words);
147 caml_gc_message(0x400, "compactions: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
148 cpct);
149 }
150
151 #ifndef NATIVE_CODE
152 caml_debugger(PROGRAM_EXIT, Val_unit);
153 #endif
154 caml_instr_atexit ();
155 if (caml_cleanup_on_exit)
156 caml_shutdown();
157 #ifdef _WIN32
158 caml_restore_win32_terminal();
159 #endif
160 exit(retcode);
161 }
162
163 #ifndef O_BINARY
164 #define O_BINARY 0
165 #endif
166 #ifndef O_TEXT
167 #define O_TEXT 0
168 #endif
169 #ifndef O_NONBLOCK
170 #ifdef O_NDELAY
171 #define O_NONBLOCK O_NDELAY
172 #else
173 #define O_NONBLOCK 0
174 #endif
175 #endif
176
177 static int sys_open_flags[] = {
178 O_RDONLY, O_WRONLY, O_APPEND | O_WRONLY, O_CREAT, O_TRUNC, O_EXCL,
179 O_BINARY, O_TEXT, O_NONBLOCK
180 };
181
182 CAMLprim value caml_sys_open(value path, value vflags, value vperm)
183 {
184 CAMLparam3(path, vflags, vperm);
185 int fd, flags, perm;
186 char_os * p;
187
188 #if defined(O_CLOEXEC)
189 flags = O_CLOEXEC;
190 #elif defined(_WIN32)
191 flags = _O_NOINHERIT;
192 #else
193 flags = 0;
194 #endif
195
196 caml_sys_check_path(path);
197 p = caml_stat_strdup_to_os(String_val(path));
198 flags |= caml_convert_flag_list(vflags, sys_open_flags);
199 perm = Int_val(vperm);
200 /* open on a named FIFO can block (PR#8005) */
201 caml_enter_blocking_section();
202 fd = open_os(p, flags, perm);
203 /* fcntl on a fd can block (PR#5069)*/
204 #if defined(F_SETFD) && defined(FD_CLOEXEC) && !defined(_WIN32) \
205 && !defined(O_CLOEXEC)
206 if (fd != -1)
207 fcntl(fd, F_SETFD, FD_CLOEXEC);
208 #endif
209 caml_leave_blocking_section();
210 caml_stat_free(p);
211 if (fd == -1) caml_sys_error(path);
212 CAMLreturn(Val_long(fd));
213 }
214
215 CAMLprim value caml_sys_close(value fd_v)
216 {
217 int fd = Int_val(fd_v);
218 caml_enter_blocking_section();
219 close(fd);
220 caml_leave_blocking_section();
221 return Val_unit;
222 }
223
224 CAMLprim value caml_sys_file_exists(value name)
225 {
226 #ifdef _WIN32
227 struct _stati64 st;
228 #else
229 struct stat st;
230 #endif
231 char_os * p;
232 int ret;
233
234 if (! caml_string_is_c_safe(name)) return Val_false;
235 p = caml_stat_strdup_to_os(String_val(name));
236 caml_enter_blocking_section();
237 ret = stat_os(p, &st);
238 caml_leave_blocking_section();
239 caml_stat_free(p);
240
241 return Val_bool(ret == 0);
242 }
243
244 CAMLprim value caml_sys_is_directory(value name)
245 {
246 CAMLparam1(name);
247 #ifdef _WIN32
248 struct _stati64 st;
249 #else
250 struct stat st;
251 #endif
252 char_os * p;
253 int ret;
254
255 caml_sys_check_path(name);
256 p = caml_stat_strdup_to_os(String_val(name));
257 caml_enter_blocking_section();
258 ret = stat_os(p, &st);
259 caml_leave_blocking_section();
260 caml_stat_free(p);
261
262 if (ret == -1) caml_sys_error(name);
263 #ifdef S_ISDIR
264 CAMLreturn(Val_bool(S_ISDIR(st.st_mode)));
265 #else
266 CAMLreturn(Val_bool(st.st_mode & S_IFDIR));
267 #endif
268 }
269
270 CAMLprim value caml_sys_remove(value name)
271 {
272 CAMLparam1(name);
273 char_os * p;
274 int ret;
275 caml_sys_check_path(name);
276 p = caml_stat_strdup_to_os(String_val(name));
277 caml_enter_blocking_section();
278 ret = unlink_os(p);
279 caml_leave_blocking_section();
280 caml_stat_free(p);
281 if (ret != 0) caml_sys_error(name);
282 CAMLreturn(Val_unit);
283 }
284
285 CAMLprim value caml_sys_rename(value oldname, value newname)
286 {
287 char_os * p_old;
288 char_os * p_new;
289 int ret;
290 caml_sys_check_path(oldname);
291 caml_sys_check_path(newname);
292 p_old = caml_stat_strdup_to_os(String_val(oldname));
293 p_new = caml_stat_strdup_to_os(String_val(newname));
294 caml_enter_blocking_section();
295 ret = rename_os(p_old, p_new);
296 caml_leave_blocking_section();
297 caml_stat_free(p_new);
298 caml_stat_free(p_old);
299 if (ret != 0)
300 caml_sys_error(NO_ARG);
301 return Val_unit;
302 }
303
304 CAMLprim value caml_sys_chdir(value dirname)
305 {
306 CAMLparam1(dirname);
307 char_os * p;
308 int ret;
309 caml_sys_check_path(dirname);
310 p = caml_stat_strdup_to_os(String_val(dirname));
311 caml_enter_blocking_section();
312 ret = chdir_os(p);
313 caml_leave_blocking_section();
314 caml_stat_free(p);
315 if (ret != 0) caml_sys_error(dirname);
316 CAMLreturn(Val_unit);
317 }
318
319 CAMLprim value caml_sys_getcwd(value unit)
320 {
321 char_os buff[4096];
322 char_os * ret;
323 #ifdef HAS_GETCWD
324 ret = getcwd_os(buff, sizeof(buff)/sizeof(*buff));
325 #else
326 caml_invalid_argument("Sys.getcwd not implemented");
327 #endif /* HAS_GETCWD */
328 if (ret == 0) caml_sys_error(NO_ARG);
329 return caml_copy_string_of_os(buff);
330 }
331
332 CAMLprim value caml_sys_unsafe_getenv(value var)
333 {
334 char_os * res, * p;
335 value val;
336
337 if (! caml_string_is_c_safe(var)) caml_raise_not_found();
338 p = caml_stat_strdup_to_os(String_val(var));
339 #ifdef _WIN32
340 res = caml_win32_getenv(p);
341 #else
342 res = getenv(p);
343 #endif
344 caml_stat_free(p);
345 if (res == 0) caml_raise_not_found();
346 val = caml_copy_string_of_os(res);
347 #ifdef _WIN32
348 caml_stat_free(res);
349 #endif
350 return val;
351 }
352
353 CAMLprim value caml_sys_getenv(value var)
354 {
355 char_os * res, * p;
356 value val;
357
358 if (! caml_string_is_c_safe(var)) caml_raise_not_found();
359 p = caml_stat_strdup_to_os(String_val(var));
360 #ifdef _WIN32
361 res = caml_win32_getenv(p);
362 #else
363 res = caml_secure_getenv(p);
364 #endif
365 caml_stat_free(p);
366 if (res == 0) caml_raise_not_found();
367 val = caml_copy_string_of_os(res);
368 #ifdef _WIN32
369 caml_stat_free(res);
370 #endif
371 return val;
372 }
373
374 char_os * caml_exe_name;
375 static value main_argv;
376
377 CAMLprim value caml_sys_get_argv(value unit)
378 {
379 CAMLparam0 (); /* unit is unused */
380 CAMLlocal2 (exe_name, res);
381 exe_name = caml_copy_string_of_os(caml_exe_name);
382 res = caml_alloc_small(2, 0);
383 Field(res, 0) = exe_name;
384 Field(res, 1) = main_argv;
385 CAMLreturn(res);
386 }
387
388 CAMLprim value caml_sys_argv(value unit)
389 {
390 return main_argv;
391 }
392
393 CAMLprim value caml_sys_modify_argv(value new_argv)
394 {
395 caml_modify_generational_global_root(&main_argv, new_argv);
396 return Val_unit;
397 }
398
399 CAMLprim value caml_sys_executable_name(value unit)
400 {
401 return caml_copy_string_of_os(caml_exe_name);
402 }
403
404 void caml_sys_init(char_os * exe_name, char_os **argv)
405 {
406 #ifdef _WIN32
407 /* Initialises the caml_win32_* globals on Windows with the version of
408 Windows which is running */
409 caml_probe_win32_version();
410 #if WINDOWS_UNICODE
411 caml_setup_win32_terminal();
412 #endif
413 #endif
414 caml_exe_name = exe_name;
415 main_argv = caml_alloc_array((void *)caml_copy_string_of_os,
416 (char const **) argv);
417 caml_register_generational_global_root(&main_argv);
418 }
419
420 #ifdef _WIN32
421 #define WIFEXITED(status) 1
422 #define WEXITSTATUS(status) (status)
423 #else
424 #if !(defined(WIFEXITED) && defined(WEXITSTATUS))
425 /* Assume old-style V7 status word */
426 #define WIFEXITED(status) (((status) & 0xFF) == 0)
427 #define WEXITSTATUS(status) (((status) >> 8) & 0xFF)
428 #endif
429 #endif
430
431 CAMLprim value caml_sys_system_command(value command)
432 {
433 CAMLparam1 (command);
434 int status, retcode;
435 char_os *buf;
436
437 if (! caml_string_is_c_safe (command)) {
438 errno = EINVAL;
439 caml_sys_error(command);
440 }
441 buf = caml_stat_strdup_to_os(String_val(command));
442 caml_enter_blocking_section ();
443 status = system_os(buf);
444 caml_leave_blocking_section ();
445 caml_stat_free(buf);
446 if (status == -1) caml_sys_error(command);
447 if (WIFEXITED(status))
448 retcode = WEXITSTATUS(status);
449 else
450 retcode = 255;
451 CAMLreturn (Val_int(retcode));
452 }
453
454 double caml_sys_time_include_children_unboxed(value include_children)
455 {
456 #ifdef HAS_GETRUSAGE
457 struct rusage ru;
458 double acc = 0.;
459
460 getrusage (RUSAGE_SELF, &ru);
461 acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
462 + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6;
463
464 if (Bool_val(include_children)) {
465 getrusage (RUSAGE_CHILDREN, &ru);
466 acc += ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6
467 + ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6;
468 }
469
470 return acc;
471 #else
472 #ifdef HAS_TIMES
473 #ifndef CLK_TCK
474 #ifdef HZ
475 #define CLK_TCK HZ
476 #else
477 #define CLK_TCK 60
478 #endif
479 #endif
480 struct tms t;
481 clock_t acc = 0;
482 times(&t);
483 acc += t.tms_utime + t.tms_stime;
484 if (Bool_val(include_children)) {
485 acc += t.tms_cutime + t.tms_cstime;
486 }
487 return (double)acc / CLK_TCK;
488 #else
489 /* clock() is standard ANSI C. We have no way of getting
490 subprocess times in this branch. */
491 return (double)clock() / CLOCKS_PER_SEC;
492 #endif
493 #endif
494 }
495
496 CAMLprim value caml_sys_time_include_children(value include_children)
497 {
498 return caml_copy_double(
499 caml_sys_time_include_children_unboxed(include_children));
500 }
501
502 double caml_sys_time_unboxed(value unit) {
503 return caml_sys_time_include_children_unboxed(Val_false);
504 }
505
506 CAMLprim value caml_sys_time(value unit)
507 {
508 return caml_copy_double(caml_sys_time_unboxed(unit));
509 }
510
511 #ifdef _WIN32
512 extern int caml_win32_random_seed (intnat data[16]);
513 #endif
514
515 CAMLprim value caml_sys_random_seed (value unit)
516 {
517 intnat data[16];
518 int n, i;
519 value res;
520 #ifdef _WIN32
521 n = caml_win32_random_seed(data);
522 #else
523 int fd;
524 n = 0;
525 /* Try /dev/urandom first */
526 fd = open("/dev/urandom", O_RDONLY, 0);
527 if (fd != -1) {
528 unsigned char buffer[12];
529 int nread = read(fd, buffer, 12);
530 close(fd);
531 while (nread > 0) data[n++] = buffer[--nread];
532 }
533 /* If the read from /dev/urandom fully succeeded, we now have 96 bits
534 of good random data and can stop here. Otherwise, complement
535 whatever we got (probably nothing) with some not-very-random data. */
536 if (n < 12) {
537 #ifdef HAS_GETTIMEOFDAY
538 struct timeval tv;
539 gettimeofday(&tv, NULL);
540 data[n++] = tv.tv_usec;
541 data[n++] = tv.tv_sec;
542 #else
543 data[n++] = time(NULL);
544 #endif
545 #ifdef HAS_UNISTD
546 data[n++] = getpid();
547 data[n++] = getppid();
548 #endif
549 }
550 #endif
551 /* Convert to an OCaml array of ints */
552 res = caml_alloc_small(n, 0);
553 for (i = 0; i < n; i++) Field(res, i) = Val_long(data[i]);
554 return res;
555 }
556
557 CAMLprim value caml_sys_const_big_endian(value unit)
558 {
559 #ifdef ARCH_BIG_ENDIAN
560 return Val_true;
561 #else
562 return Val_false;
563 #endif
564 }
565
566 /* returns a value that represents a number of bits */
567 CAMLprim value caml_sys_const_word_size(value unit)
568 {
569 return Val_long(8 * sizeof(value));
570 }
571
572 /* returns a value that represents a number of bits */
573 CAMLprim value caml_sys_const_int_size(value unit)
574 {
575 return Val_long(8 * sizeof(value) - 1) ;
576 }
577
578 /* returns a value that represents a number of words */
579 CAMLprim value caml_sys_const_max_wosize(value unit)
580 {
581 return Val_long(Max_wosize) ;
582 }
583
584 CAMLprim value caml_sys_const_ostype_unix(value unit)
585 {
586 return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Unix"));
587 }
588
589 CAMLprim value caml_sys_const_ostype_win32(value unit)
590 {
591 return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Win32"));
592 }
593
594 CAMLprim value caml_sys_const_ostype_cygwin(value unit)
595 {
596 return Val_bool(0 == strcmp(OCAML_OS_TYPE,"Cygwin"));
597 }
598
599 CAMLprim value caml_sys_const_backend_type(value unit)
600 {
601 return Val_int(1); /* Bytecode backed */
602 }
603 CAMLprim value caml_sys_get_config(value unit)
604 {
605 CAMLparam0 (); /* unit is unused */
606 CAMLlocal2 (result, ostype);
607
608 ostype = caml_copy_string(OCAML_OS_TYPE);
609 result = caml_alloc_small (3, 0);
610 Field(result, 0) = ostype;
611 Field(result, 1) = Val_long (8 * sizeof(value));
612 #ifdef ARCH_BIG_ENDIAN
613 Field(result, 2) = Val_true;
614 #else
615 Field(result, 2) = Val_false;
616 #endif
617 CAMLreturn (result);
618 }
619
620 CAMLprim value caml_sys_read_directory(value path)
621 {
622 CAMLparam1(path);
623 CAMLlocal1(result);
624 struct ext_table tbl;
625 char_os * p;
626 int ret;
627
628 caml_sys_check_path(path);
629 caml_ext_table_init(&tbl, 50);
630 p = caml_stat_strdup_to_os(String_val(path));
631 caml_enter_blocking_section();
632 ret = caml_read_directory(p, &tbl);
633 caml_leave_blocking_section();
634 caml_stat_free(p);
635 if (ret == -1){
636 caml_ext_table_free(&tbl, 1);
637 caml_sys_error(path);
638 }
639 caml_ext_table_add(&tbl, NULL);
640 result = caml_copy_string_array((char const **) tbl.contents);
641 caml_ext_table_free(&tbl, 1);
642 CAMLreturn(result);
643 }
644
645 /* Return true if the value is a filedescriptor (int) that is
646 * (presumably) open on an interactive terminal */
647 CAMLprim value caml_sys_isatty(value chan)
648 {
649 int fd;
650 value ret;
651
652 fd = (Channel(chan))->fd;
653 #ifdef _WIN32
654 ret = Val_bool(caml_win32_isatty(fd));
655 #else
656 ret = Val_bool(isatty(fd));
657 #endif
658
659 return ret;
660 }
661