l4/pkg/ocaml/contrib/byterun/sys.c

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