Ejemplo n.º 1
0
CAMLexport value caml_check_urgent_gc (value extra_root)
{
  CAMLparam1 (extra_root);
  if (caml_force_major_slice) caml_minor_collection();
  CAMLreturn (extra_root);
}
Ejemplo n.º 2
0
CAMLprim value
uint64_of_uint56(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_uint64((uint64_t)Uint56_val(v)));
}
Ejemplo n.º 3
0
CAMLprim value
uint64_of_float(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_uint64((uint64_t)Double_val(v)));
}
Ejemplo n.º 4
0
value get_memory_usage() {
  CAMLparam0();
  CAMLreturn(Val_long(usage()));
}
Ejemplo n.º 5
0
value ml_qapp_exec (value self) {
  CAMLparam1(self);
  CAMLreturn( Val_int (((QApplication*)self)->exec()) );
}
Ejemplo n.º 6
0
CAMLprim value
int32_of_float(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_int32((int32_t)Double_val(v)));
}
Ejemplo n.º 7
0
CAMLprim value re_replacement_text(value repl, value groups, value orig)
{
  CAMLparam3(repl, groups, orig);
  CAMLlocal1(res);
  mlsize_t start, end, len, n;
  char * p, * q;
  int c;

  len = 0;
  p = String_val(repl);
  n = string_length(repl);
  while (n > 0) {
    c = *p++; n--;
    if(c != '\\')
      len++;
    else {
      if (n == 0) failwith("Str.replace: illegal backslash sequence");
      c = *p++; n--;
      switch (c) {
      case '\\':
        len++; break;
      case '0': case '1': case '2': case '3': case '4':
      case '5': case '6': case '7': case '8': case '9':
        c -= '0';
        if (c*2 >= Wosize_val(groups))
          failwith("Str.replace: reference to unmatched group");
        start = Long_val(Field(groups, c*2));
        end = Long_val(Field(groups, c*2 + 1));
        if (start == (mlsize_t) -1)
          failwith("Str.replace: reference to unmatched group");
        len += end - start;
        break;
      default:
        len += 2; break;
      }
    }
  }
  res = alloc_string(len);
  p = String_val(repl);
  q = String_val(res);
  n = string_length(repl);
  while (n > 0) {
    c = *p++; n--;
    if(c != '\\')
      *q++ = c;
    else {
      c = *p++; n--;
      switch (c) {
      case '\\':
        *q++ = '\\'; break;
      case '0': case '1': case '2': case '3': case '4':
      case '5': case '6': case '7': case '8': case '9':
        c -= '0';
        start = Long_val(Field(groups, c*2));
        end = Long_val(Field(groups, c*2 + 1));
        len = end - start;
        memmove (q, &Byte(orig, start), len);
        q += len;
        break;
      default:
        *q++ = '\\'; *q++ = c; break;
      }
    }
  }
  CAMLreturn(res);
}
Ejemplo n.º 8
0
CAMLprim value brlapiml_enterRawMode(value handle, value driverName)
{
  CAMLparam2(handle, driverName);
  brlapiCheckError(enterRawMode, String_val(driverName));
  CAMLreturn(Val_unit);
}
Ejemplo n.º 9
0
CAMLprim value brlapiml_leaveRawMode(value handle, value unit)
{
  CAMLparam2(handle, unit);
  brlapi(leaveRawMode);
  CAMLreturn(Val_unit);
}
Ejemplo n.º 10
0
CAMLprim value brlapiml_writeText(value handle, value cursor, value text)
{
  CAMLparam3(handle, cursor, text);
  brlapiCheckError(writeText, Int_val(cursor), String_val(text));
  CAMLreturn(Val_unit);
}
Ejemplo n.º 11
0
CAMLprim value brlapiml_acceptAllKeys(value handle, value unit)
{
  CAMLparam2(handle, unit);
  brlapiCheckError(acceptAllKeys);
  CAMLreturn(Val_unit);
}
Ejemplo n.º 12
0
CAMLprim value brlapiml_setFocus(value handle, value tty)
{
  CAMLparam2(handle, tty);
  brlapiCheckError(setFocus, Int_val(tty));
  CAMLreturn(Val_unit);
}
Ejemplo n.º 13
0
CAMLprim value brlapiml_closeConnection(value handle, value unit)
{
  CAMLparam2(handle, unit);
  brlapi(closeConnection);
  CAMLreturn(Val_unit);
}
Ejemplo n.º 14
0
/* For debugging */
value hh_heap_size() {
  CAMLparam0();
  CAMLreturn(Val_long(*heap - heap_init));
}
Ejemplo n.º 15
0
CAMLprim value
int32_of_uint56(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_int32((int32_t)Uint56_val(v)));
}
Ejemplo n.º 16
0
CAMLprim value brlapiml_suspendDriver(value handle, value driverName)
{
  CAMLparam2(handle, driverName);
  brlapiCheckError(suspendDriver, String_val(driverName));
  CAMLreturn(Val_unit);
}
Ejemplo n.º 17
0
CAMLprim value
int32_of_nativeint(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_int32((int32_t)Nativeint_val(v)));
}
Ejemplo n.º 18
0
CAMLprim value brlapiml_resumeDriver(value handle, value unit)
{
  CAMLparam2(handle, unit);
  brlapi(resumeDriver);
  CAMLreturn(Val_unit);
}
Ejemplo n.º 19
0
CAMLprim value
int32_of_int64(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_int32((int32_t)Int64_val(v)));
}
Ejemplo n.º 20
0
/* exception occurs */
CAMLprim value brlapiml_setExceptionHandler(value unit)
{
  CAMLparam1(unit);
  brlapi_setExceptionHandler(raise_brlapi_exception);
  CAMLreturn(Val_unit);
}
Ejemplo n.º 21
0
CAMLprim value netcgi2_apache_request_finfo (value rv)
{
    CAMLparam1 (rv);
    request_rec *r = Request_rec_val (rv);
    CAMLlocal5 (v, sb, atime, mtime, ctime);

#if APACHE2
    if (r->finfo.filetype != APR_NOFILE) /* Some statbuf */
    {
        atime = (r->finfo.valid & APR_FINFO_ATIME) ?
                copy_double ((double) apr_time_sec (r->finfo.atime)) :
                copy_double (0.);
        mtime = (r->finfo.valid & APR_FINFO_MTIME) ?
                copy_double ((double) apr_time_sec (r->finfo.mtime)) :
                copy_double (0.);
        ctime = (r->finfo.valid & APR_FINFO_CTIME) ?
                copy_double ((double) apr_time_sec (r->finfo.ctime)) :
                copy_double (0.);

        sb = alloc_small (12, 0);
        Field (sb, 0) = Val_int (r->finfo.device);
        Field (sb, 1) = Val_int (r->finfo.inode);
        Field (sb, 2) =
            cst_to_constr (r->finfo.filetype, file_kind_table,
                           sizeof (file_kind_table) / sizeof (int), 0);
        Field (sb, 3) = Val_int (r->finfo.protection);
        Field (sb, 4) = Val_int (r->finfo.nlink);
        Field (sb, 5) = Val_int (r->finfo.user);
        Field (sb, 6) = Val_int (r->finfo.group);
        Field (sb, 7) = Val_int (0); /* FIXME rdev? */
        Field (sb, 8) = Val_int (r->finfo.size); /* FIXME 64 bit file offsets */

        Field (sb, 9) = atime;
        Field (sb, 10) = mtime;
        Field (sb, 11) = ctime;

        v = alloc (1, 0);		/* The "Some" block. */
        Field (v, 0) = sb;
    }
    else
        v = Val_int (0);		/* None. */

#else /* not APACHE2 */

    if (r->finfo.st_mode)		/* Some statbuf */
    {
        /* This code copied and modified from otherlibs/unix/stat.c. */
        atime = copy_double ((double) r->finfo.st_atime);
        mtime = copy_double ((double) r->finfo.st_mtime);
        ctime = copy_double ((double) r->finfo.st_ctime);

        sb = alloc_small (12, 0);
        Field (sb, 0) = Val_int (r->finfo.st_dev);
        Field (sb, 1) = Val_int (r->finfo.st_ino);
        Field (sb, 2) =
            cst_to_constr (r->finfo.st_mode & S_IFMT, file_kind_table,
                           sizeof (file_kind_table) / sizeof (int), 0);
        Field (sb, 3) = Val_int (r->finfo.st_mode & 07777);
        Field (sb, 4) = Val_int (r->finfo.st_nlink);
        Field (sb, 5) = Val_int (r->finfo.st_uid);
        Field (sb, 6) = Val_int (r->finfo.st_gid);
        Field (sb, 7) = Val_int (r->finfo.st_rdev);
        Field (sb, 8) = Val_int (r->finfo.st_size); /* FIXME: 64 bit file offsets */
        Field (sb, 9) = atime;
        Field (sb, 10) = mtime;
        Field (sb, 11) = ctime;

        v = alloc (1, 0);		/* The "Some" block. */
        Field (v, 0) = sb;
    }
    else
        v = Val_int (0);		/* None. */
#endif /* not APACHE2 */

    CAMLreturn (v);
}
Ejemplo n.º 22
0
static int compareHandle(value h1, value h2)
{
  CAMLparam2(h1, h2);
  CAMLreturn(memcmp(Data_custom_val(h1), Data_custom_val(h2), brlapi_getHandleSize()));
}
Ejemplo n.º 23
0
CAMLprim value unix_lockf(value fd, value cmd, value span)
{
  CAMLparam3(fd, cmd, span);
  OVERLAPPED overlap;
  intnat l_len;
  HANDLE h;
  OSVERSIONINFO version;
  LARGE_INTEGER cur_position;
  LARGE_INTEGER beg_position;
  LARGE_INTEGER lock_len;
  LARGE_INTEGER zero;
  DWORD err = NO_ERROR;

  version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
  if(GetVersionEx(&version) == 0) {
    invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform.");
  }
  if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) {
    invalid_argument("lockf only supported on WIN32_NT platforms");
  }

  h = Handle_val(fd);
  
  l_len = Long_val(span);

  /* No matter what, we need the current position in the file */
  zero.HighPart = zero.LowPart = 0;
  set_file_pointer(h, zero, &cur_position, FILE_CURRENT);

  /* All unused fields must be set to zero */
  memset(&overlap, 0, sizeof(overlap));

  if(l_len == 0) {
    /* Lock from cur to infinity */
    lock_len.QuadPart = -1;
    overlap.OffsetHigh = cur_position.HighPart;
    overlap.Offset     = cur_position.LowPart ;
  }
  else if(l_len > 0) {
    /* Positive file offset */
    lock_len.QuadPart = l_len;
    overlap.OffsetHigh = cur_position.HighPart;
    overlap.Offset     = cur_position.LowPart ;
  }
  else {
    /* Negative file offset */
    lock_len.QuadPart = - l_len;
    if (lock_len.QuadPart > cur_position.QuadPart) {
      errno = EINVAL;
      uerror("lockf", Nothing);
    }
    beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart;
    overlap.OffsetHigh = beg_position.HighPart;
    overlap.Offset     = beg_position.LowPart ;
  }

  switch(Int_val(cmd)) {
  case 0: /* F_ULOCK - unlock */
    if (! UnlockFileEx(h, 0,
		       lock_len.LowPart, lock_len.HighPart, &overlap))
      err = GetLastError();
    break;
  case 1: /* F_LOCK - blocking write lock */
    enter_blocking_section();
    if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0,
		     lock_len.LowPart, lock_len.HighPart, &overlap))
      err = GetLastError();
    leave_blocking_section();
    break;
  case 2: /* F_TLOCK - non-blocking write lock */
    if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
		     lock_len.LowPart, lock_len.HighPart, &overlap))
      err = GetLastError();
    break;
  case 3: /* F_TEST - check whether a write lock can be obtained */
    /*  I'm doing this by aquiring an immediate write
     * lock and then releasing it. It is not clear that
     * this behavior matches anything in particular, but
     * it is not clear the nature of the lock test performed
     * by ocaml (unix) currently. */
    if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0,
		   lock_len.LowPart, lock_len.HighPart, &overlap)) {
      UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap);
    } else {
      err = GetLastError();
    }
    break;
  case 4: /* F_RLOCK - blocking read lock */
    enter_blocking_section();
    if (! LockFileEx(h, 0, 0,
		     lock_len.LowPart, lock_len.HighPart, &overlap))
      err = GetLastError();
    leave_blocking_section();
    break;
  case 5: /* F_TRLOCK - non-blocking read lock */
    if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0,
		     lock_len.LowPart, lock_len.HighPart, &overlap))
      err = GetLastError();
    break;
  default:
    errno = EINVAL;
    uerror("lockf", Nothing);
  }
  if (err != NO_ERROR) {
    win32_maperr(err);
    uerror("lockf", Nothing);
  }
  CAMLreturn(Val_unit);
}
Ejemplo n.º 24
0
CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
{
  CAMLparam3(vnode, vserv, vopts);
  CAMLlocal3(vres, v, e);
  mlsize_t len;
  char * node, * serv;
  struct addrinfo hints;
  struct addrinfo * res, * r;
  int retcode;

  /* Extract "node" parameter */
  len = string_length(vnode);
  if (len == 0) {
    node = NULL;
  } else {
    node = stat_alloc(len + 1);
    strcpy(node, String_val(vnode));
  }
  /* Extract "service" parameter */
  len = string_length(vserv);
  if (len == 0) {
    serv = NULL;
  } else {
    serv = stat_alloc(len + 1);
    strcpy(serv, String_val(vserv));
  }
  /* Parse options, set hints */
  memset(&hints, 0, sizeof(hints));
  hints.ai_family = PF_UNSPEC;
  for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) {
    v = Field(vopts, 0);
    if (Is_block(v))
      switch (Tag_val(v)) {
      case 0:                   /* AI_FAMILY of socket_domain */
        hints.ai_family = socket_domain_table[Int_val(Field(v, 0))];
        break;
      case 1:                   /* AI_SOCKTYPE of socket_type */
        hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))];
        break;
      case 2:                   /* AI_PROTOCOL of int */
        hints.ai_protocol = Int_val(Field(v, 0));
        break;
      }
    else
      switch (Int_val(v)) {
      case 0:                   /* AI_NUMERICHOST */
        hints.ai_flags |= AI_NUMERICHOST; break;
      case 1:                   /* AI_CANONNAME */
        hints.ai_flags |= AI_CANONNAME; break;
      case 2:                   /* AI_PASSIVE */
        hints.ai_flags |= AI_PASSIVE; break;
      }
  }
  /* Do the call */
  enter_blocking_section();
  retcode = getaddrinfo(node, serv, &hints, &res);
  leave_blocking_section();
  if (node != NULL) stat_free(node);
  if (serv != NULL) stat_free(serv);
  /* Convert result */
  vres = Val_int(0);
  if (retcode == 0) {
    for (r = res; r != NULL; r = r->ai_next) {
      e = convert_addrinfo(r);
      v = alloc_small(2, 0);
      Field(v, 0) = e;
      Field(v, 1) = vres;
      vres = v;
    }
    freeaddrinfo(res);
  }
  CAMLreturn(vres);
}
Ejemplo n.º 25
0
value ml_crc32_init (value unit) 
{
	CAMLparam1 (unit);
	InitCrcTable();
	CAMLreturn (unit);	
}
CAMLprim value sunml_lsolver_call_atimes(value vcptr, value vv, value vz)
{
    CAMLparam3(vcptr, vv, vz);
    caml_raise_constant(SUNDIALS_EXN(NotImplementedBySundialsVersion));
    CAMLreturn(Val_unit);
}
Ejemplo n.º 27
0
CAMLprim value
uint64_of_nativeint(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_uint64((uint64_t)Nativeint_val(v)));
}
CAMLprim value sunml_lsolver_call_psetup(value vcptr)
{
    CAMLparam1(vcptr);
    caml_raise_constant(SUNDIALS_EXN(NotImplementedBySundialsVersion));
    CAMLreturn(Val_unit);
}
Ejemplo n.º 29
0
CAMLprim value
uint64_of_int8(value v)
{
  CAMLparam1(v);
  CAMLreturn (copy_uint64((uint64_t)Int8_val(v)));
}
Ejemplo n.º 30
0
static ssize_t recv_buffer(int fd, int fds[3])
{
  struct iovec iov = { .iov_base = buffer, .iov_len = sizeof(buffer) };
  struct msghdr msg = {
    .msg_iov = &iov, .msg_iovlen = 1,
    .msg_controllen = CMSG_SPACE(3 * sizeof(int)),
  };
  msg.msg_control = alloca(msg.msg_controllen);
  memset(msg.msg_control, 0, msg.msg_controllen);

  ssize_t recvd;
  NO_EINTR(recvd, recvmsg(fd, &msg, 0));
  if (recvd == -1)
  {
    perror("recvmsg");
    return -1;
  }

  if (recvd < 4)
  {
    ssize_t recvd_;
    do {
      NO_EINTR(recvd_, recv(fd, buffer + recvd, sizeof(buffer) - recvd, 0));
      if (recvd_ > 0)
        recvd += recvd_;
    } while (recvd_ > 0 && recvd < 4);
  }

  size_t target = -1;

  if (recvd > 4)
  {
    target =
      unbyte(buffer[0],0) | unbyte(buffer[1],1) |
      unbyte(buffer[2],2) | unbyte(buffer[3],3);

    if (recvd < target)
    {
      ssize_t recvd_;
      do {
        NO_EINTR(recvd_, recv(fd, buffer + recvd, sizeof(buffer) - recvd, 0));
        if (recvd_ > 0)
          recvd += recvd_;
      } while (recvd_ > 0 && recvd < target);
    }
  }

  struct cmsghdr *cm = CMSG_FIRSTHDR(&msg);

  int *fds0 = (int*)CMSG_DATA(cm);
  int nfds = (cm->cmsg_len - CMSG_LEN(0)) / sizeof(int);

  /* Check malformed packet */
  if (nfds != 3 || recvd != target || buffer[recvd-1] != '\0')
  {
    int i;
    for (i = 0; i < nfds; ++i)
      close(fds0[i]);
    return -1;
  }

  fds[0] = fds0[0];
  fds[1] = fds0[1];
  fds[2] = fds0[2];

  return recvd;
}

value ml_merlin_server_setup(value path, value strfd)
{
  CAMLparam2(path, strfd);
  CAMLlocal2(payload, ret);
  char *endptr = NULL;

  int fd = strtol(String_val(strfd), &endptr, 0);
  if (endptr && *endptr == '\0')
  {
    /* (path, fd) */
    payload = caml_alloc(2, 0);
    Store_field(payload, 0, path);
    Store_field(payload, 1, Val_int(fd));

    /* Some payload */
    ret = caml_alloc(1, 0);
    Store_field(ret, 0, payload);
  }
  else
  {
    fprintf(stderr, "ml_merlin_server_setup(\"%s\",\"%s\"): invalid argument\n",
        String_val(path), String_val(strfd));
    unlink(String_val(path));
    /* None */
    ret = Val_unit;
  }

  CAMLreturn(ret);
}

value ml_merlin_server_accept(value server, value val_timeout)
{
  CAMLparam2(server, val_timeout);
  CAMLlocal4(ret, client, args, context);

  // Compute timeout
  double timeout = Double_val(val_timeout);
  struct timeval tv;
  tv.tv_sec = timeout;
  tv.tv_usec = (timeout - tv.tv_sec) * 1000000;

  // Select on server
  int serverfd = Int_val(Field(server, 1));
  int selectres;
  fd_set readset;
  do {
    FD_ZERO(&readset);
    FD_SET(serverfd, &readset);
    selectres = select(serverfd + 1, &readset, NULL, NULL, &tv);
  } while (selectres == -1 && errno == EINTR);

  int fds[3], clientfd;
  ssize_t len = -1;

  if (selectres > 0)
  {
    NO_EINTR(clientfd, accept(serverfd, NULL, NULL));
    len = recv_buffer(clientfd, fds);
  }

  if (len == -1)
    ret = Val_unit; /* None */
  else {
    context = caml_alloc(4, 0); /* (clientfd, stdin, stdout, stderr) */
    Store_field(context, 0, Val_int(clientfd));
    Store_field(context, 1, Val_int(fds[0]));
    Store_field(context, 2, Val_int(fds[1]));
    Store_field(context, 3, Val_int(fds[2]));

    ssize_t i, j;
    int argc = 0;
    for (i = 4; i < len; ++i)
      if (buffer[i] == '\0')
        argc += 1;

    args = caml_alloc(argc, 0);

    argc = 0;
    for (i = 4, j = 4; i < len; ++i)
    {
      if (buffer[i] == '\0')
      {
        Store_field(args, argc, caml_copy_string((const char *)&buffer[j]));
        j = i + 1;
        argc += 1;
      }
    }

    client = caml_alloc(2, 0); /* (context, args) */
    Store_field(client, 0, context);
    Store_field(client, 1, args);

    ret = caml_alloc(1, 0); /* Some client */
    Store_field(ret, 0, client);
  }

  CAMLreturn(ret);
}