ports//devel/ocaml-annexlib/work/annexlib-0.13.2/util

#include "config.h"

#if defined(__FreeBSD__)
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/uio.h>
#include <netinet/in.h>
#endif

#ifdef HAVE_STRPTIME
#define _XOPEN_SOURCE 500
#ifdef HAVE_FEATURES_H
#include <features.h>
#endif
#endif

#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/fail.h>
#include <caml/callback.h>
#include <caml/signals.h>

#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif

#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif

#ifdef HAVE_NETDB_H
#include <netdb.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef HAVE_SYS_RESOURCE_H
#include <sys/resource.h>
#endif

#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif

#ifdef HAVE_SYS_SYSMACROS_H
#include <sys/sysmacros.h>
#endif

#ifdef HAVE_FCNTL_H
#include <fcntl.h>
#endif

/* Standard headers */
#include <ctype.h>
#include <limits.h>
#include <locale.h>
#include <time.h>
#include <string.h>
#include <errno.h>
#include <stdio.h>

#ifdef HAVE_SYS_SENDFILE_H
#include <sys/sendfile.h>
#endif

#define NONE            Val_int(0)     
#define SOME            0             

#define Nothing 0

/* From the unix lib */
#define UNIX_BUFFER_SIZE 16384
extern void uerror(char *, value) Noreturn;

static char*
str_option(value v)
{
  if (v == NONE)
    return (char*) NULL;
  else 
    return String_val(Field(v,SOME));
}

struct locale_conversion {
  value hash;
  int ltype;
  const char *name;
};

struct locale_conversion contable[] = {
  {0, LC_ALL, "LC_ALL"},
  {0, LC_COLLATE, "LC_COLLATE"},
  {0, LC_CTYPE, "LC_CTYPE"},
  {0, LC_MONETARY, "LC_MONETARY"},
  {0, LC_MESSAGES, "LC_MESSAGES"},
  {0, LC_NUMERIC, "LC_NUMERIC"},
  {0, LC_TIME, "LC_TIME"},
  {0, 0, 0}
};
int contable_init = 0;

value signpos_conversion[6];
int signpos_set = 0;

value
stew_set_locale(value whatopt, value type) {
  CAMLparam2(type, whatopt);
  CAMLlocal2(ret, nl);
  char *newlocale;
  struct locale_conversion *c;
  char *locale = str_option(whatopt);
  int whattype = 0;

  if (contable_init == 0) {

    contable_init = 1;

    for (c = contable; c && c->name; c++)
      c->hash = hash_variant((char *)c->name);
  }
    
  for (c = contable; c && c->name; c++) {
    if (c->hash == type) {
      whattype = c->ltype;
      break;
    }
  }
  
  if (!(c && c->name))
    failwith("Locale.set: Unknown locale type");

  newlocale = setlocale(whattype, locale);

  if (!newlocale)
    CAMLreturn(NONE);

  nl = copy_string(newlocale);  
  ret = alloc_small(1, SOME);
  Field(ret, 0) = nl;
  
  CAMLreturn(ret);
}

/* The numeric bits of a struct lconv */
value
stew_localeconv_n (void) {
  CAMLparam0();
  CAMLlocal4(dp, ts, g, res);
  struct lconv *l;

  l = localeconv();

  dp = copy_string(l->decimal_point);
  ts = copy_string(l->thousands_sep);
  g = copy_string(l->grouping);

  res = alloc_tuple(3);
  Field(res, 0) = dp;
  Field(res, 1) = ts;
  Field(res, 2) = g;
  
  CAMLreturn(res);
}

/* The monetary bits of a struct lconv */
value
stew_localeconv_m (void) {
  CAMLparam0();
  CAMLlocal5(ics, cs, dp, ts, g);
  CAMLlocal3(ps, ns, res);
  struct lconv *l;

  if (!signpos_set) {
    signpos_set = 1;
    signpos_conversion[0] = hash_variant("SurroundBoth");
    signpos_conversion[1] = hash_variant("SignPrecedesBoth");
    signpos_conversion[2] = hash_variant("SignSucceedsBoth");
    signpos_conversion[3] = hash_variant("SignPrecedesCS");
    signpos_conversion[4] = hash_variant("SignSucceedsCS");
    signpos_conversion[5] = hash_variant("UnknownOrder");
  }

  l = localeconv();

  ics = copy_string(l->int_curr_symbol);
  cs = copy_string(l->currency_symbol);
  dp = copy_string(l->mon_decimal_point);
  ts = copy_string(l->mon_thousands_sep);
  g = copy_string(l->mon_grouping);
  ps = copy_string(l->positive_sign);
  ns = copy_string(l->negative_sign);

  res = alloc_tuple(15);
  Field(res, 0) = ics;
  Field(res, 1) = cs;
  Field(res, 2) = dp;
  Field(res, 3) = ts;
  Field(res, 4) = g;
  Field(res, 5) = ps;
  Field(res, 6) = ns;
  Field(res, 7) = Val_int(l->int_frac_digits);
  Field(res, 8) = Val_int(l->int_frac_digits);
  Field(res, 9) = Val_bool(l->p_cs_precedes);
  Field(res, 10) = Val_bool(l->p_sep_by_space);
  Field(res, 11) = Val_bool(l->n_cs_precedes);
  Field(res, 12) = Val_bool(l->n_sep_by_space);
  if (l->p_sign_posn > 4)
    Field(res, 13) = signpos_conversion[5];
  else
    Field(res, 13) = signpos_conversion[(int)l->p_sign_posn];
  if (l->n_sign_posn > 4)
    Field(res, 14) = signpos_conversion[5];
  else
    Field(res, 14) = signpos_conversion[(int)l->n_sign_posn];

  CAMLreturn(res);
}

value
stew_is_alpha(value c) {
  if (isalpha(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_space(value c) {
  if (isspace(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_number(value c) {
  if (isdigit(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_lower(value c) {
  if (islower(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_upper(value c) {
  if (isupper(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_punct(value c) {
  if (ispunct(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_print(value c) {
  if (isprint(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_graph(value c) {
  if (isgraph(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_is_xdigit(value c) {
  if (isxdigit(Int_val(c)))
    return Val_true;
  else
    return Val_false;
}

value
stew_to_lower(value c) {
  return Val_int(tolower(Int_val(c)));
}

value
stew_to_upper(value c) {
  return Val_int(toupper(Int_val(c)));
}

static value
alloc_tm(struct tm *tm)
{
  value res;
  res = alloc_tuple(9);
  Field(res,0) = Val_int(tm->tm_sec);
  Field(res,1) = Val_int(tm->tm_min);
  Field(res,2) = Val_int(tm->tm_hour);
  Field(res,3) = Val_int(tm->tm_mday);
  Field(res,4) = Val_int(tm->tm_mon);
  Field(res,5) = Val_int(tm->tm_year);
  Field(res,6) = Val_int(tm->tm_wday);
  Field(res,7) = Val_int(tm->tm_yday);
  Field(res,8) = tm->tm_isdst ? Val_true : Val_false;
  return res;
}

static struct tm*
tm_val(value t, struct tm *tm) {
  if (!tm)
    return NULL;
  tm->tm_sec = Int_val(Field(t, 0));
  tm->tm_min = Int_val(Field(t, 1));
  tm->tm_hour = Int_val(Field(t, 2));
  tm->tm_mday = Int_val(Field(t, 3));
  tm->tm_mon = Int_val(Field(t, 4));
  tm->tm_year = Int_val(Field(t, 5));
  tm->tm_wday = Int_val(Field(t, 6));
  tm->tm_yday = Int_val(Field(t, 7));
  tm->tm_isdst = -1; /* tm.tm_isdst = Bool_val(Field(t, 8)); */
  return tm;
}

value
stew_time_int32(value unit) {
  time_t t;

  time(&t);

  return copy_int32(t);
}

value
stew_ctime(value for_time) {
  CAMLparam1(for_time);
  CAMLlocal1(ret);
  time_t t1 = (time_t)Int32_val(for_time);
  char buf[50];

  ctime_r(&t1, buf);

  ret = copy_string(buf);

  CAMLreturn(ret);
}

value
stew_asctime(value for_time) {
  CAMLparam1(for_time);
  CAMLlocal1(ret);
  struct tm tm;
  char buf[50];

  tm_val(for_time, &tm);

  asctime_r(&tm, buf);

  ret = copy_string(buf);

  CAMLreturn(ret);
}

/* 
value
stew_strftime_time(value fmt, value for_time) {
  CAMLparam2(fmt, for_time);
  CAMLlocal1(ret);
  time_t t1 = (time_t)Int32_val(for_time);
  struct tm t2;
  char buf[8192];

  localtime_r(&t1, &t2);

  strftime(buf, sizeof buf, String_val(fmt), &t2);

  ret = copy_string(buf);

  CAMLreturn(ret);
}
*/

value
stew_strftime_tm(value fmt, value for_time) {
  CAMLparam2(fmt, for_time);
  CAMLlocal1(ret);
  struct tm tm = {0};
  char buf[8192];

  tm_val(for_time, &tm);
  
  strftime(buf, sizeof buf, String_val(fmt), &tm);

  ret = copy_string(buf);

  CAMLreturn(ret);
}

value
stew_strptime_tm(value time_str, value fmt)
{
#ifdef HAVE_STRPTIME
  CAMLparam2(time_str, fmt);
  CAMLlocal1(ret);
  struct tm tm = {0};
  char *s;

  s = strptime(String_val(time_str), String_val(fmt), &tm);

  if (s == NULL || *s != '\0') {
    failwith("extern C function stew_strptime_tm failed");
  }

  ret = alloc_tm(&tm);

  CAMLreturn(ret);
#else
  failwith("stew_strptime_tm not implemented");
#endif
}

value stew_gmtime(value t)
{
  time_t tyme;
  struct tm tm;
  tyme = (time_t) Int32_val(t);
  gmtime_r(&tyme, &tm);
  return alloc_tm(&tm);
}

value stew_localtime(value t)
{
  time_t tyme;
  struct tm tm;
  tyme = (time_t) Int32_val(t);
  localtime_r(&tyme, &tm);
  return alloc_tm(&tm);
}

value stew_mktime(value t)
{
  CAMLparam1(t);
  CAMLlocal3(res, clockval, tmval);
  struct tm tm;
  time_t tyme;
  tm_val(t, &tm);
  tyme = mktime(&tm);
  tmval = alloc_tm(&tm);
  clockval = copy_int32(tyme);
  res = alloc_tuple(2);
  Field(res, 0) = clockval;
  Field(res, 1) = tmval;
  CAMLreturn(res);
}

value stew_difftime(value a, value b) {
  return copy_double(difftime((time_t)Int32_val(a), (time_t)Int32_val(b)));
}

value stew_sendfile(value o, value i, value off, value count) {
  size_t len;
  off_t offset, wrote;
  int infd, outfd;


  infd = Int_val(o);
  outfd = Int_val(i);
  offset = Int_val(off);
  len = Int_val(count);

#if defined(linux)
  enter_blocking_section();
  len = sendfile(outfd, infd, &offset, len);
  leave_blocking_section();
  if (len >= 0)
    return Val_int(len);
  else
    uerror("sendfile", Nothing);
#elif defined(__FreeBSD__)
  enter_blocking_section();
  len = sendfile(outfd, infd, offset, len,
		 NULL, &wrote, 0);
  leave_blocking_section();
  if (len == 0)
    return Val_int(wrote);
  else
    uerror("sendfile", Nothing);
#else
      failwith("sendfile unimplemented!");
#endif

}

/* From getserv.c */
#ifdef HAVE_GETSERVENT
static value alloc_service_entry(struct servent *entry)
{
  value res;
  value name = Val_unit, aliases = Val_unit, proto = Val_unit;

  Begin_roots3 (name, aliases, proto);
    name = copy_string(entry->s_name);
    aliases = copy_string_array((const char**)entry->s_aliases);
    proto = copy_string(entry->s_proto);
    res = alloc_tuple(4);
    Field(res,0) = name;
    Field(res,1) = aliases;
    Field(res,2) = Val_int(ntohs(entry->s_port));
    Field(res,3) = proto;
  End_roots();
  return res;
}
#endif

value stew_getservent(value unit) {
#ifdef HAVE_GETSERVENT
  struct servent *s = getservent();
  if (s == NULL)
    raise_not_found();
  return alloc_service_entry(s);
#else
  failwith("getservent unimplemented");
#endif
}

value stew_setservent(value stay) {
#ifdef HAVE_SETSERVENT
  setservent(Bool_val(stay));
  return Val_unit;
#else
  failwith("setservent unimplemented");
#endif
}

value stew_endservent(value unit) {
#ifdef HAVE_ENDSERVENT
  endservent();
  return Val_unit;
#else
  failwith("endservent unimplemented");
#endif
}

value stew_hash_variant(value s) {
  return hash_variant(String_val(s));
}

value stew_strcoll(value a, value b) {
  int r;

  r = strcoll(String_val(a), String_val(b));

  if (r < 0)
    return Val_int(-1);
  else if (r == 0)
    return Val_int(0);
  else 
    return Val_int(1);
}

value stew_pread(value fd, value buf, value vofs, value len) {
#ifdef HAVE_PREAD
  long numbytes, ofs;
  int ret;
  char iobuf[UNIX_BUFFER_SIZE];
  
  Begin_root(buf);
  numbytes = Long_val(len);
  ofs = Long_val(vofs);
  if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
  enter_blocking_section();
  ret = pread(Int_val(fd), iobuf, ofs, (int) numbytes);
  leave_blocking_section();
  if (ret == -1) uerror("pread", Nothing);
  memmove(&Byte(buf, ofs), iobuf, ret);
  End_roots();
  return Val_int(ret);
#else
  failwith("pread unimplemented");
#endif
}

value stew_pwrite(value fd, value buf, value vofs, value vlen) {
#ifdef HAVE_PWRITE
  long ofs, len, written;
  int numbytes, ret;
  char iobuf[UNIX_BUFFER_SIZE];
  
  Begin_root(buf);
  ofs = Long_val(vofs);
  len = Long_val(vlen);
  written = 0;
  while (len > 0) {
    numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
    memmove(iobuf, &Byte(buf, ofs), numbytes);
    enter_blocking_section();
    ret = pwrite(Int_val(fd), iobuf, ofs, numbytes);
    leave_blocking_section();
    if (ret == -1) {
      if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0)
	break;
      uerror("pwrite", Nothing);
    }
    written += ret;
    ofs += ret;
    len -= ret;
  }
  End_roots();
  return Val_long(written);
#else
  failwith("pwrite unimplemented");
#endif
}

value stew_gettimeofday(value u) {
#ifdef HAVE_GETTIMEOFDAY
  struct timeval t;
  CAMLparam1(u);
  CAMLlocal3(res, sec, usec);

  if (gettimeofday(&t, NULL))
    uerror("gettimeofday", Nothing);

  sec = copy_int32(t.tv_sec);
  usec = copy_int32(t.tv_usec);
  res = alloc_tuple(2);
  Field(res, 0) = sec;
  Field(res, 1) = usec;
  CAMLreturn(res);
#else
  failwith("gettimeofday unimplemented");
#endif
}

value stew_getrusage(value whov) {
#ifdef HAVE_GETRUSAGE
  struct rusage r;
  int who;
  CAMLparam1(whov);
  CAMLlocal5(res, utime, stime, sec, usec);

  if (Int_val(whov) == 0)
    who = RUSAGE_SELF;
  else
    who = RUSAGE_CHILDREN;

  if (getrusage(who, &r))
    uerror("getrusage", Nothing);

  sec = copy_int32(r.ru_utime.tv_sec);
  usec = copy_int32(r.ru_utime.tv_usec);
  utime = alloc_tuple(2);
  Field(utime, 0) = sec;
  Field(utime, 1) = usec;

  sec = copy_int32(r.ru_stime.tv_sec);
  usec = copy_int32(r.ru_stime.tv_usec);
  stime = alloc_tuple(2);
  Field(stime, 0) = sec;
  Field(stime, 1) = usec;

  res = alloc_tuple(16);
  Field(res, 0) = utime;
  Field(res, 1) = stime;
    
#ifdef __APPLE__
  /* For some reason, the OS X headers only define these
     structures if _POSIX_C_SOURCE is undefined. However, since
     the headers seem to always define this, #undefing it doesn't
     do any good. *sigh*
  */
  {
    int n;
    for (n = 2; n < 16; n++)
      Field(res, n) = Val_long(0);
  }
#else
  Field(res, 2) = Val_long(r.ru_maxrss);
  Field(res, 3) = Val_long(r.ru_ixrss);
  Field(res, 4) = Val_long(r.ru_idrss);
  Field(res, 5) = Val_long(r.ru_isrss);
  Field(res, 6) = Val_long(r.ru_minflt);
  Field(res, 7) = Val_long(r.ru_majflt);
  Field(res, 8) = Val_long(r.ru_nswap);
  Field(res, 9) = Val_long(r.ru_inblock);
  Field(res, 10) = Val_long(r.ru_oublock);
  Field(res, 11) = Val_long(r.ru_msgsnd);
  Field(res, 12) = Val_long(r.ru_msgrcv);
  Field(res, 13) = Val_long(r.ru_nsignals);
  Field(res, 14) = Val_long(r.ru_nvcsw);
  Field(res, 15) = Val_long(r.ru_nivcsw);
#endif
  CAMLreturn(res);

#else
  failwith("getrusage unimplemented");
#endif
}

value stew_getrlimit(value resource) {
#ifdef HAVE_GETRLIMIT
  CAMLparam1(resource);
  CAMLlocal1(retval);
  int r;
  struct rlimit lim;

  switch (Int_val(resource)) {
  case 0:
    r = RLIMIT_CPU;
    break;
  case 1:
    r = RLIMIT_FSIZE;
    break;
  case 2:
    r = RLIMIT_DATA;
    break;
  case 3:
    r = RLIMIT_STACK;
    break;
  case 4:
    r = RLIMIT_CORE;
    break;
  case 5:
#ifdef RLIMIT_RSS
    r = RLIMIT_RSS;
#else
    failwith("RSS is not defined by your os");
#endif
    break;
  case 6:
#ifdef RLIMIT_NPROC
    r = RLIMIT_NPROC;
#else
    failwith("NPROC not implimented by your OS");
#endif
    break;
  case 7:
#ifdef RLIMIT_NOFILE
    r = RLIMIT_NOFILE;
#else
    r = RLIMIT_OFILE:
#endif
    break;
  case 8:
#ifdef RLIMIT_MEMLOCK
    r = RLIMIT_MEMLOCK;
#else
    failwith("MEMLOCK is not defined by your os");
#endif
    break;
#if defined(linux)
  case 9:
    r = RLIMIT_AS;
    break;
#endif
  default:
    errno = EINVAL;
    uerror("getrlimit", Nothing);    
  }

  if (getrlimit(r, &lim) < 0) 
    uerror("getrlimit", Nothing);

  
  retval = alloc_tuple(2);
  Field(retval, 0) = Val_int(lim.rlim_cur);
  Field(retval, 1) = Val_int(lim.rlim_max);

  CAMLreturn(retval);

#else
  failwith("getrlimit unimplemented");
#endif
}

value stew_setrlimit(value resource, value rlimit) {
#ifdef HAVE_SETRLIMIT
  int r;
  struct rlimit lim;

  switch (Int_val(resource)) {
  case 0:
    r = RLIMIT_CPU;
    break;
  case 1:
    r = RLIMIT_FSIZE;
    break;
  case 2:
    r = RLIMIT_DATA;
    break;
  case 3:
    r = RLIMIT_STACK;
    break;
  case 4:
    r = RLIMIT_CORE;
    break;
  case 5:
#ifdef RLIMIT_RSS
    r = RLIMIT_RSS;
#else
    failwith("RSS is not defined by your os");
#endif
    break;
  case 6:
#ifdef RLIMIT_NPROC
    r = RLIMIT_NPROC;
#else
    failwith("NPROC is not defined by your os");
#endif
    break;
  case 7:
#ifdef RLIMIT_NOFILE
    r = RLIMIT_NOFILE;
#else
    r = RLIMIT_OFILE:
#endif
    break;
  case 8:
#ifdef RLIMIT_MEMLOCK
    r = RLIMIT_MEMLOCK;
#else
    failwith("MEMLOCK is not defined by your os");
#endif
    break;
#if defined(linux)
  case 9:
    r = RLIMIT_AS;
    break;
#endif
  default:
    errno = EINVAL;
    uerror("getrlimit", Nothing);    
  }

  lim.rlim_cur = Int_val(Field(rlimit, 0));
  lim.rlim_max = Int_val(Field(rlimit, 1));

  if (setrlimit(r, &lim) < 0) 
    uerror("setrlimit", Nothing);

  return Val_unit;

#else
  failwith("getrlimit unimplemented");
#endif
}

value
stew_setpgid(value pid, value pgid) {
#ifdef HAVE_SETPGID
  if (setpgid(Int_val(pid), Int_val(pgid)) < 0)
    uerror("setpgid", Nothing);
  return Val_unit;
#else
  failwith("setgpid unimplemented");
#endif
}

value
stew_getpgid(value pid) {
#ifdef HAVE_GETPGID
  int ret = getpgid(Int_val(pid));
  if (ret < 0)
    uerror("getpgid", Nothing);
  return Val_int(ret);
#else
  failwith("getgpid unimplemented");
#endif
}

value
stew_getpgrp(value unit) {
#ifdef HAVE_GETPGRP
  int ret = getpgrp();
  if (ret < 0)
    uerror("getpgrp", Nothing);
  return Val_int(ret);
#else
  failwith("getpgrp unimplemented");
#endif
}

value
stew_setpgrp(value unit) {
#if defined(HAVE_SETPGRP)
  /* This needs a better test to tell if we have 0, 1, or 2 argument
     forms of setpgrp() */
#if defined(__FreeBSD__) || defined(__APPLE__)
  if (setpgid(0,0) < 0) 
#else
  if (setpgrp() < 0) 
#endif
    uerror("setpgrp", Nothing);
  return Val_unit;
#else /* !HAVE_SETPGRP */
  failwith("setpgrp unimplemented");
#endif
}


#if defined(__APPLE__) && !defined(makedev)
#define major(x)        ((int32_t)(((u_int32_t)(x) >> 24) & 0xff))
#define minor(x)        ((int32_t)((x) & 0xffffff))
#define makedev(x,y)    ((dev_t)(((x) << 24) | (y)))
#endif


value
stew_mknod(value fname, value mod, value type, value major, value minor) {
#ifdef HAVE_MKNOD
  dev_t dev;
  mode_t mode = Int_val(mod);

  dev = makedev(Int_val(major), Int_val(minor));

  if (Int_val(type) == 0) 
    mode |= S_IFBLK;
  else
    mode |= S_IFCHR;

  if (mknod(String_val(fname), mode, dev) < 0)
    uerror("mknod", fname);

  return Val_unit;
#else
  failwith("mknod unimplemented");
#endif
}
syntax highlighted by Code2HTML, v. 0.9.1