Пример #1
0
CAMLprim value caml_condition_wait(value cond, value mut)
{
  int retcode;
  HANDLE m = Mutex_val(mut);
  HANDLE s = Condition_val(cond)->sem;
  HANDLE handles[2];

  Condition_val(cond)->count ++;
  Begin_roots2(cond, mut)       /* prevent deallocation of cond and mutex */
    enter_blocking_section();
    /* Release mutex */
    ReleaseMutex(m);
    /* Wait for semaphore to be non-null, and decrement it.
       Simultaneously, re-acquire mutex. */
    handles[0] = s;
    handles[1] = m;
    retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
    leave_blocking_section();
  End_roots();
  if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
  return Val_unit;
}
Пример #2
0
static void camlzip_error(char * fn, value vzs)
{
  char * msg;
  value s1 = Val_unit, s2 = Val_unit, bucket = Val_unit;

  msg = ZStream_val(vzs)->msg;
  if (msg == NULL) msg = "";
  if (camlzip_error_exn == NULL) {
    camlzip_error_exn = caml_named_value("Zlib.Error");
    if (camlzip_error_exn == NULL)
      invalid_argument("Exception Zlib.Error not initialized");
  }
  Begin_roots3(s1, s2, bucket);
    s1 = copy_string(fn);
    s2 = copy_string(msg);
    bucket = alloc_small(3, 0);
    Field(bucket, 0) = *camlzip_error_exn;
    Field(bucket, 1) = s1;
    Field(bucket, 2) = s2;
  End_roots();
  mlraise(bucket);
}
Пример #3
0
CAMLprim value unix_pipe(value unit)
{
  SECURITY_ATTRIBUTES attr;
  HANDLE readh, writeh;
  value readfd = Val_unit, writefd = Val_unit, res;

  attr.nLength = sizeof(attr);
  attr.lpSecurityDescriptor = NULL;
  attr.bInheritHandle = TRUE;
  if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
    win32_maperr(GetLastError());
    uerror("pipe", Nothing);
  }
  Begin_roots2(readfd, writefd)
    readfd = win_alloc_handle(readh);
    writefd = win_alloc_handle(writeh);
    res = alloc_small(2, 0);
    Field(res, 0) = readfd;
    Field(res, 1) = writefd;
  End_roots();
  return res;
}
value caml_gr_dump_image(value image)
{
  int width, height, i, j;
  XImage * idata, * imask;
  value m = Val_unit;

  Begin_roots2(image, m);
    caml_gr_check_open();
    width = Width_im(image);
    height = Height_im(image);
    m = alloc(height, 0);
    for (i = 0; i < height; i++) {
      value v = alloc(width, 0);
      modify(&Field(m, i), v);
    }

    idata =
      XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1),
                ZPixmap);
    for (i = 0; i < height; i++)
      for (j = 0; j < width; j++)
        Field(Field(m, i), j) =
          Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
    XDestroyImage(idata);

    if (Mask_im(image) != None) {
      imask =
        XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1,
                  ZPixmap);
      for (i = 0; i < height; i++)
        for (j = 0; j < width; j++)
          if (XGetPixel(imask, j, i) == 0)
            Field(Field(m, i), j) = Val_int(Transparent);
      XDestroyImage(imask);
    }
  End_roots();
  return m;
}
Пример #5
0
CAMLprim value unix_select(value readfds, value writefds, value exceptfds, 
                           value timeout)
{
  fd_set read, write, except;
  int maxfd;
  double tm;
  struct timeval tv;
  struct timeval * tvp;
  int retcode;
  value res;

  Begin_roots3 (readfds, writefds, exceptfds);
    maxfd = -1;
    fdlist_to_fdset(readfds, &read, &maxfd);
    fdlist_to_fdset(writefds, &write, &maxfd);
    fdlist_to_fdset(exceptfds, &except, &maxfd);
    tm = Double_val(timeout);
    if (tm < 0.0)
      tvp = (struct timeval *) NULL;
    else {
      tv.tv_sec = (int) tm;
      tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
      tvp = &tv;
    }
    enter_blocking_section();
    retcode = select(maxfd + 1, &read, &write, &except, tvp);
    leave_blocking_section();
    if (retcode == -1) uerror("select", Nothing);
    readfds = fdset_to_fdlist(readfds, &read);
    writefds = fdset_to_fdlist(writefds, &write);
    exceptfds = fdset_to_fdlist(exceptfds, &except);
    res = alloc_small(3, 0);
    Field(res, 0) = readfds;
    Field(res, 1) = writefds;
    Field(res, 2) = exceptfds;
  End_roots();
  return res;
}
Пример #6
0
CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
{
  intnat ofs, len, written;
  DWORD numbytes, numwritten;
  char iobuf[UNIX_BUFFER_SIZE];
  DWORD err = 0;

  Begin_root (buf);
    ofs = Long_val(vofs);
    len = Long_val(vlen);
    written = 0;
    if (len > 0) {
      numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len;
      memmove (iobuf, &Byte(buf, ofs), numbytes);
      if (Descr_kind_val(fd) == KIND_SOCKET) {
        int ret;
        SOCKET s = Socket_val(fd);
        enter_blocking_section();
        ret = send(s, iobuf, numbytes, 0);
        if (ret == SOCKET_ERROR) err = WSAGetLastError();
        leave_blocking_section();
        numwritten = ret;
      } else {
        HANDLE h = Handle_val(fd);
        enter_blocking_section();
        if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL))
          err = GetLastError();
        leave_blocking_section();
      }
      if (err) {
        win32_maperr(err);
        uerror("single_write", Nothing);
      }
      written = numwritten;
    }
  End_roots();
  return Val_long(written);
}
Пример #7
0
void unix_error(int errcode, char *cmdname, value cmdarg)
{
  value res;
  value name = Val_unit, err = Val_unit, arg = Val_unit;
  int errconstr;

  Begin_roots3 (name, err, arg);
    arg = cmdarg == Nothing ? copy_string("") : cmdarg;
    name = copy_string(cmdname);
    err = unix_error_of_code (errcode);
    if (unix_error_exn == NULL) {
      unix_error_exn = caml_named_value("Unix.Unix_error");
      if (unix_error_exn == NULL)
        invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma");
    }
    res = alloc_small(4, 0);
    Field(res, 0) = *unix_error_exn;
    Field(res, 1) = err;
    Field(res, 2) = name;
    Field(res, 3) = arg;
  End_roots();
  mlraise(res);
}
Пример #8
0
static value alloc_process_status(int pid, int status)
{
  value st, res;

  if (WIFEXITED(status)) {
    st = alloc_small(1, TAG_WEXITED);
    Field(st, 0) = Val_int(WEXITSTATUS(status));
  }
  else if (WIFSTOPPED(status)) {
    st = alloc_small(1, TAG_WSTOPPED);
    Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
  }
  else {
    st = alloc_small(1, TAG_WSIGNALED);
    Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
  }
  Begin_root (st);
    res = alloc_small(2, 0);
    Field(res, 0) = Val_int(pid);
    Field(res, 1) = st;
  End_roots();
  return res;
}
Пример #9
0
CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags)
{
    SOCKET s = Socket_val(sock);
    int flg = convert_flag_list(flags, msg_flag_table);
    int ret;
    intnat numbytes;
    char iobuf[UNIX_BUFFER_SIZE];
    DWORD err = 0;

    Begin_root (buff);
    numbytes = Long_val(len);
    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
    enter_blocking_section();
    ret = recv(s, iobuf, (int) numbytes, flg);
    if (ret == -1) err = WSAGetLastError();
    leave_blocking_section();
    if (ret == -1) {
        win32_maperr(err);
        uerror("recv", Nothing);
    }
    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
    End_roots();
    return Val_int(ret);
}
Пример #10
0
static void caml_zlib_error(char * fn, value vzs)
{
  char * msg;
  value s1 = Val_unit, s2 = Val_unit, tuple = Val_unit, bucket = Val_unit;

  msg = ZStream_val(vzs)->msg;
  if (msg == NULL) msg = "";
  if (caml_zlib_error_exn == NULL) {
    caml_zlib_error_exn = caml_named_value("Cryptokit.Error");
    if (caml_zlib_error_exn == NULL)
      invalid_argument("Exception Cryptokit.Error not initialized");
  }
  Begin_roots4(s1, s2, tuple, bucket);
    s1 = copy_string(fn);
    s2 = copy_string(msg);
    tuple = alloc_small(2, 0);
    Field(tuple, 0) = s1;
    Field(tuple, 1) = s2;
    bucket = alloc_small(2, 0);
    Field(bucket, 0) = *caml_zlib_error_exn;
    Field(bucket, 1) = tuple;
  End_roots();
  mlraise(bucket);
}
Пример #11
0
/* Initialisation, based on tkMain.c */
value camltk_opentk(value argv) /* ML */
{
  /* argv must contain argv[0], the application command name */
  value tmp = Val_unit;
  char *argv0;

  Begin_root(tmp);

  if ( argv == Val_int(0) ){
    failwith("camltk_opentk: argv is empty");
  }
  argv0 = String_val( Field( argv, 0 ) );

  if (!cltk_slave_mode) {
    /* Create an interpreter, dies if error */
#if TCL_MAJOR_VERSION >= 8
    Tcl_FindExecutable(String_val(argv0));
#endif
    cltclinterp = Tcl_CreateInterp();

    if (Tcl_Init(cltclinterp) != TCL_OK)
      tk_error(cltclinterp->result);
    Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);

    { /* Sets argv if needed */
      int argc = 0;

      tmp = Field(argv, 1); /* starts from argv[1] */
      while ( tmp != Val_int(0) ) {
	argc++;
	tmp = Field(tmp, 1);
      }

      if( argc != 0 ){
	int i;
	char *args;
	char **tkargv;
	char argcstr[256];

	tkargv = malloc( sizeof( char* ) * argc );

	tmp = Field(argv, 1); /* starts from argv[1] */
	i = 0;
	while ( tmp != Val_int(0) ) {
	  tkargv[i] = String_val(Field(tmp, 0));
	  tmp = Field(tmp, 1);
	  i++;
	}
	
	sprintf( argcstr, "%d", argc );

        Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
        args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
        Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
        Tcl_Free(args);
	free( tkargv );
      }
    }
    if (Tk_Init(cltclinterp) != TCL_OK)
      tk_error(cltclinterp->result);

    /* Retrieve the main window */
    cltk_mainWindow = Tk_MainWindow(cltclinterp);

    if (NULL == cltk_mainWindow)
      tk_error(cltclinterp->result);
  
    Tk_GeometryRequest(cltk_mainWindow,200,200);
  }

  /* Create the camlcallback command */
  Tcl_CreateCommand(cltclinterp,
                    CAMLCB, CamlCBCmd, 
                    (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);

  /* This is required by "unknown" and thus autoload */
  Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
  /* Our hack for implementing break in callbacks */
  Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);

  /* Load the traditional rc file */
  {
    char *home = getenv("HOME");
    if (home != NULL) {
      char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
      f[0]='\0';
      strcat(f, home);
      strcat(f, "/");
      strcat(f, RCNAME);
      if (0 == access(f,R_OK)) 
        if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
          stat_free(f);
          tk_error(cltclinterp->result);
        };
      stat_free(f);
    }
  }

  End_roots();
  return Val_unit;
}
Пример #12
0
CAMLprim value mlresolv_query(value vdname, value vclass, value vtype)
{
  union {
    HEADER hdr;              /* defined in resolv.h */
    u_char buf[PACKETSZ];    /* defined in arpa/nameser.h */
  } response;
  int rc;

  u_char *cp, *tcp;
  u_char *eom;

  char r_name[MAXDNAME+1];
  u_short r_class;
  u_short r_type;
  u_int32_t r_ttl;
  u_short r_len;

  int ancount, qdcount;

  value vres = Val_emptylist;

  if(vtype == caml_hash_variant("PTR")) {
    int a, b, c, d;
    a = b = c = d = 0;
    sscanf(String_val(vdname), "%u.%u.%u.%u", &a, &b, &c, &d);
    sprintf(r_name, "%u.%u.%u.%u.in-addr.arpa", d, c, b, a);
    rc = res_query(r_name,
		   mlvariant_to_c(rr_class, vclass),
		   mlvariant_to_c(rr_type, vtype),
		   (u_char*)&response, sizeof(response));
  } else
    rc = res_query(String_val(vdname),
		   mlvariant_to_c(rr_class, vclass),
		   mlvariant_to_c(rr_type, vtype),
		   (u_char*)&response, sizeof(response));

  if (rc < 0) {
    switch (h_errno) {
    case NETDB_INTERNAL:  
      mlresolv_error(errno);
    case HOST_NOT_FOUND:  /* Authoritative Answer Host not found */
      raise_constant(*mlresolv_host_not_found_exn);
    case TRY_AGAIN:       /* Non-Authoritative Host not found, or SERVERFAIL */
      raise_constant(*mlresolv_try_again_exn);
    case NO_RECOVERY:
      raise_constant(*mlresolv_no_recovery_exn);
    case NO_DATA:         /* Valid name, no data record of requested type */
      raise_constant(*mlresolv_no_data_exn);
    case NETDB_SUCCESS:   /* no problem */
    defaykt:
      failwith("res_query: unknown error");
    }
  }

  cp = (u_char *)&response.buf + sizeof(HEADER);
  eom = (u_char *)&response.buf + rc;

  ancount = ntohs(response.hdr.ancount) + ntohs(response.hdr.nscount);
  qdcount = ntohs(response.hdr.qdcount);
  for (; (qdcount > 0) && (cp < eom); qdcount--) {
    rc = dn_skipname(cp, eom) + QFIXEDSZ;
    if(rc < 0)
      failwith("dn_skipname failed");
    cp += rc;
  }

  for (; (ancount > 0) && (cp < eom); ancount--) {
    value vrdata, vfields = Val_unit;

    rc = dn_expand(response.buf, eom, cp, (void*)r_name, MAXDNAME);
    if(rc < 0)
      failwith("dn_expand1 failed");

    cp += rc;

    NS_GET16(r_type, cp);
    NS_GET16(r_class, cp);
    NS_GET32(r_ttl, cp);
    NS_GET16(r_len, cp);

    if(cp + r_len > eom) /* is this check necessary? */
      r_len = eom - cp;

    tcp = cp;

    switch(r_type) {

    case ns_t_a:
      /* if(r_class == ns_c_in || r_class == ns_c_hs) { */

      if(INADDRSZ > r_len)
	vfields = copy_string("");
      else {
	struct in_addr inaddr;
	char *address;

	bcopy(tcp, (char *)&inaddr, INADDRSZ);
	address = (char *)inet_ntoa(inaddr);
	vfields = copy_string(address);
      }
      break;

    case ns_t_cname:
    case ns_t_ns:
    case ns_t_mb:
    case ns_t_md:
    case ns_t_mf:
    case ns_t_mg:
    case ns_t_mr:
    case ns_t_ptr: 
    case ns_t_nsap_ptr:
      {
	char r_name[MAXDNAME+1];
	rc = dn_expand(response.buf, eom, cp, (void *) r_name, MAXDNAME);
	if(rc < 0)
	  vfields = copy_string("");
	else
	  vfields = copy_string(r_name);
	break;
    }

    case ns_t_null:  /* max up to 65535 */
      vfields = caml_alloc_string(r_len);
      memmove(String_val(vfields), cp, r_len);
      break;

    case ns_t_txt: {
      int txtlen, rdata_len = r_len;
      value newcons, txt;
      vfields = Val_emptylist;

      while(tcp < eom && *tcp <= rdata_len) {
	txtlen = *tcp++;
	txt = caml_alloc_string(txtlen);
	memmove(String_val(txt), tcp, txtlen);
	tcp += txtlen;
	rdata_len -= txtlen+1;

	newcons = alloc_small(2, 0);
	Field(newcons, 0) = txt;
	Field(newcons, 1) = vfields;
	vfields = newcons;
      }
      break;
    }

    case ns_t_srv:
      if(INT16SZ * 3 <= r_len) {
	char r_name[MAXDNAME+1];
	int prio, weight, port;
      
	NS_GET16(prio, tcp);
	NS_GET16(weight, tcp);
	NS_GET16(port, tcp);

	rc = dn_expand(response.buf, eom, tcp, (void *) r_name, MAXDNAME);

	vfields = alloc_small(4, 0);
	Field(vfields, 0) = Val_int(prio);
	Field(vfields, 1) = Val_int(weight);
	Field(vfields, 2) = Val_int(port);
      
	if(rc < 0)
	  Field(vfields, 3) = copy_string("");
	else
	  Field(vfields, 3) = copy_string(r_name);
      }
      break;

    case ns_t_mx:
    case ns_t_rt:
    case ns_t_afsdb:
      if(INT16SZ <= r_len) {
	char r_name[MAXDNAME+1];
	int prio;

	NS_GET16(prio, tcp);

	rc = dn_expand(response.buf, eom, tcp, (void *) r_name, MAXDNAME);

	vfields = alloc_small(2, 0);
	Field(vfields, 0) = Val_int(prio);

	if(rc < 0)
	  Field(vfields, 1) = copy_string("");
	else
	  Field(vfields, 1) = copy_string(r_name);
      }
      break;

    case ns_t_soa: 
      {
	char mname[MAXDNAME+1];
	char rname[MAXDNAME+1];
	u_int serial, minimum;
	int refresh, retry, expire;
	
	if((rc = dn_expand(response.buf, eom, tcp, (void *)mname, MAXDNAME)) < 0)
	  break;
	tcp += rc;
	
	if((rc = dn_expand(response.buf, eom, tcp, (void *)rname, MAXDNAME)) < 0)
	  break;
	tcp += rc;
	
	if (tcp - cp + INT32SZ * 5 > r_len)
	  break;
      
	NS_GET32(serial, tcp);
	NS_GET32(refresh, tcp);
	NS_GET32(retry, tcp);
	NS_GET32(expire, tcp);
	NS_GET32(minimum, tcp);
      
	vfields = alloc_small(7, 0);
	Field(vfields, 0) = copy_string(mname);
	Field(vfields, 1) = copy_string(rname);
	Field(vfields, 2) = Val_int(serial);
	Field(vfields, 3) = Val_int(refresh);
	Field(vfields, 4) = Val_int(retry);
	Field(vfields, 5) = Val_int(expire);
	Field(vfields, 6) = Val_int(minimum);
      }
      break;

    case ns_t_minfo: 
      {
	char rmailbx[MAXDNAME+1];
	char emailbx[MAXDNAME+1];

	if((rc = dn_expand(response.buf, eom, tcp, rmailbx, MAXDNAME)) < 0)
	  break;
	tcp += rc;
	if((rc = dn_expand(response.buf, eom, tcp, emailbx, MAXDNAME)) < 0)
	  break;

	vfields = alloc_small(2, 0);
	Field(vfields, 0) = copy_string(rmailbx);
	Field(vfields, 1) = copy_string(emailbx);
      }
      break;

      /* two strings */
    case ns_t_hinfo:
    case ns_t_isdn: /* <ISDN-address> <sa> */
    case ns_t_nsap:
      if(r_len > 0 && *tcp < r_len) {
	value str1;
	value str2;

	rc = *tcp++;
	if(r_type == ns_t_nsap) {
	  int result = 0;
	  for(; rc; rc--, tcp++)
	    result += result * 10 + (*tcp - 0x38);
	  str1 = Val_int(result);
	}
	else {
	  str1 = caml_alloc_string(rc);
	  memmove(String_val(str1), tcp, rc);
	  tcp += rc;
	}      
	if(rc + 1 > r_len && *tcp + rc + 2 >= r_len) {
	  rc = *tcp++;
	  str2 = caml_alloc_string(rc);
	  memmove(String_val(str2), tcp, rc);
	}
	else
	  str2 = copy_string("");

	vfields = caml_alloc_small(2, 0);
	Field(vfields, 0) = str1;
	Field(vfields, 1) = str2;
      }
      break;

    case ns_t_wks:
      
      if(INADDRSZ + 1 <= r_len) {
	struct in_addr inaddr;
	char* address;
	u_short protocol;
	value bitmap;

	bcopy(tcp, (char *) &inaddr, INADDRSZ);
	address = (char*) inet_ntoa(inaddr);
	tcp += INADDRSZ;
      
	protocol = *tcp++;  /* getprotobynumber(*cp) */
      
	/*
	  n = 0;
	  while (cp < eom) {
	  c = *cp++;
	  do {
	  if (c & 0200) {
	  int port;
	  
	  port = htons((u_short)n);
	  if (protocol != NULL)
	  service = getservbyport(port, protocol->p_name);
	  else
	  service = NULL;
	  
	  if (service != NULL)
	  doprintf((" %s", service->s_name));
	  else
	  doprintf((" %s", dtoa(n)));
	}
	c <<= 1;
	} while (++n & 07);
	}
	doprintf((" )"));
	*/
      
	bitmap = caml_alloc_string(r_len - INADDRSZ - 1);
	memmove(String_val(bitmap), tcp, eom - tcp);
      
	vfields = alloc_small(4, 0);
	Field(vfields, 0) = copy_string(address);
	Field(vfields, 1) = Val_int(protocol);
	Field(vfields, 2) = bitmap;
      }
      break;

    case ns_t_rp:  /* <mbox-dname> <txt-dname> */
      {
	char rname1[MAXDNAME+1];
	char rname2[MAXDNAME+1];

	rc = dn_expand(response.buf, eom, tcp, rname1, MAXDNAME);
	if(rc < 0)
	  break;
	tcp += rc;
	
	rc = dn_expand(response.buf, eom, tcp, rname2, MAXDNAME);
	if(rc < 0)
	  break;

	vfields = alloc_small(2, 0);
	Field(vfields, 0) = copy_string(rname1);
	Field(vfields, 1) = copy_string(rname2);
      }
      break;

    case ns_t_x25: /* <PSDN-address> */
      if(r_len > 0 && *tcp >= r_len) {
	rc = *tcp++;
	vfields = caml_alloc_string(rc);
	memmove(String_val(vfields), tcp, rc);
      }
      else
	vfields = copy_string("");
      break;
      

    case ns_t_px:
      if(r_len > INT16SZ) {
	int pref;
	char rname1[MAXDNAME];
	char rname2[MAXDNAME];

	NS_GET16(pref, tcp);
	rc = dn_expand(response.buf, eom, tcp, rname1, MAXDNAME);
	if(rc < 0)
	  break;
	tcp += rc;
	rc = dn_expand(response.buf, eom, tcp, rname2, MAXDNAME);
	if(rc < 0)
	  break;
	tcp += rc;

	vfields = alloc_small(2, 0);
	Field(vfields, 0) = copy_string(rname1);
	Field(vfields, 1) = copy_string(rname2);
      }
      break;

    case ns_t_gpos:
      if(r_len > 0 && *tcp <= r_len) {
	float f1, f2, f3;
	char *tmp;
	rc = *tcp++;

	tmp = (char *) malloc(rc + 1);
	bcopy(tcp, tmp, rc);
	tmp[rc] = '\0';
	f1 = atof(tmp);
	tcp += rc;
	
	if(tcp < eom && tcp + *tcp <= eom) {
	  if(*tcp > rc)
	    tmp = realloc(tmp, *tcp);
	  rc = *tcp++;
	  bcopy(tcp, tmp, rc);
	  tmp[rc] = '\0';
	  f2 = atof(tmp);
	  tcp += rc;
	}
	else
	  f2 = 0.0;

	if(tcp < eom && tcp + *tcp <= eom) {
	  if(*tcp > rc)
	    tmp = realloc(tmp, *tcp);
	  rc = *tcp++;
	  bcopy(tcp, tmp, rc);
	  tmp[rc] = '\0';
	  f3 = atof(tmp);
	  tcp += rc;
	}
	else
	  f3 = 0.0;

	free(tmp);

	vfields = alloc_small(3, 0);
	Field(vfields, 0) = copy_double((double)f1);
	Field(vfields, 1) = copy_double((double)f2);
	Field(vfields, 2) = copy_double((double)f3);
      }	
      break;

    case ns_t_loc:
      failwith("LOC not implemented");

      /*
      if(r_len > 0 && *tcp != 0)
	failwith("Invalid version in LOC RDATA");

      if(r_len > 0) {
	rc = INT
      n = INT32SZ + 3*INT32SZ;
      if (check_size(rname, type, cp, msg, eor, n) < 0)
	break;
      c = _getlong(cp);
      cp += INT32SZ;
      
      n = _getlong(cp);
      doprintf(("\t%s ", pr_spherical(n, "N", "S")));
      cp += INT32SZ;
      
      n = _getlong(cp);
      doprintf((" %s ", pr_spherical(n, "E", "W")));
      cp += INT32SZ;
      
      n = _getlong(cp);
      doprintf((" %sm ", pr_vertical(n, "", "-")));
      cp += INT32SZ;
      
      doprintf((" %sm", pr_precision((c >> 16) & 0xff)));
      doprintf((" %sm", pr_precision((c >>  8) & 0xff)));
      doprintf((" %sm", pr_precision((c >>  0) & 0xff)));
      break;
      */

      /*
    case T_UID:
    case T_GID:
      if(INT32SZ <= r_len)
	NS_GET32(rc, cp);
      
      if (dlen == INT32SZ) {
        n = _getlong(cp);
	doprintf(("\t%s", dtoa(n)));
	cp += INT32SZ;
      }
      break;
      
    case T_UINFO:
      doprintf(("\t\"%s\"", stoa(cp, dlen, TRUE)));
      cp += dlen;
      break;

    case T_UNSPEC:
      cp += dlen;
      break;
      
    case T_AAAA:
      if (dlen == IPNGSIZE) {
	doprintf(("\t%s", ipng_ntoa(cp)));
	cp += IPNGSIZE;
      }
      break;
      
    case T_SIG:
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      if (n >= T_FIRST && n <= T_LAST)
	doprintf(("\t%s", pr_type(n)));
      else
	doprintf(("\t%s", dtoa(n)));
      cp += INT16SZ;
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
      doprintf((" %s", dtoa(n)));
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
      doprintf((" %s", dtoa(n)));
      
      n = 3*INT32SZ + INT16SZ;
      if (check_size(rname, type, cp, msg, eor, n) < 0)
	break;
      doprintf((" ("));
      
      n = _getlong(cp);
      doprintf(("\n\t\t\t%s", dtoa(n)));
      doprintf(("\t\t;original ttl"));
      cp += INT32SZ;
      
      n = _getlong(cp);
      doprintf(("\n\t\t\t%s", pr_date(n)));
      doprintf(("\t;signature expiration"));
      cp += INT32SZ;
      
      n = _getlong(cp);
      doprintf(("\n\t\t\t%s", pr_date(n)));
      doprintf(("\t;signature inception"));
      cp += INT32SZ;
      
      n = _getshort(cp);
      doprintf(("\n\t\t\t%s", dtoa(n)));
      doprintf(("\t\t;key tag"));
      cp += INT16SZ;
      
      n = expand_name(rname, type, cp, msg, eom, dname);
      if (n < 0)
	break;
      doprintf(("\n\t\t\t%s", pr_name(dname)));
      cp += n;
      
      if (cp < eor) {
	register char *buf;
	register int size;
	  
	n = eor - cp;
	buf = base_ntoa(cp, n);
	size = strlength(buf);
	cp += n;
	  
	while ((n = (size > 64) ? 64 : size) > 0) {
	  doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
	  buf += n; size -= n;
	}
      }
      doprintf(("\n\t\t\t)"));
      break;
      
    case T_KEY:
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      doprintf(("\t0x%s", xtoa(n)));
      cp += INT16SZ;
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
        doprintf((" %s", dtoa(n)));
	
        if (check_size(rname, type, cp, msg, eor, 1) < 0)
	  break;
        n = *cp++;
        doprintf((" %s", dtoa(n)));
	
        if (cp < eor) {
	  register char *buf;
	  register int size;
	    
	  n = eor - cp;
	  buf = base_ntoa(cp, n);
	  size = strlength(buf);
	  cp += n;
	    
	  doprintf((" ("));
	  while ((n = (size > 64) ? 64 : size) > 0) {
	    doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
	    buf += n; size -= n;
	  }
	  doprintf(("\n\t\t\t)"));
	}
        break;
	
    case T_NXT:
      n = expand_name(rname, type, cp, msg, eom, dname);
      if (n < 0)
	break;
      doprintf(("\t%s", pr_name(dname)));
      cp += n;
      
      n = 0;
      while (cp < eor) {
	c = *cp++;
	do {
	  if (c & 0200) {
	    if (n >= T_FIRST && n <= T_LAST)
	      doprintf((" %s", pr_type(n)));
	    else
	      doprintf((" %s", dtoa(n)));
                }
	  c <<= 1;
	} while (++n & 07);
      }
      break;
      
    case T_NAPTR:
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      doprintf(("\t%s", dtoa(n)));
      cp += INT16SZ;
      
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      doprintf((" %s", dtoa(n)));
      cp += INT16SZ;
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
      doprintf((" \"%s\"", stoa(cp, n, TRUE)));
      cp += n;
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
      doprintf((" \"%s\"", stoa(cp, n, TRUE)));
      cp += n;
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
      doprintf((" \"%s\"", stoa(cp, n, TRUE)));
      cp += n;
      
      n = expand_name(rname, type, cp, msg, eom, dname);
      if (n < 0)
	break;
      doprintf((" %s", pr_name(dname)));
      cp += n;
      break;
      
    case T_KX:
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      doprintf(("\t%s", dtoa(n)));
      cp += INT16SZ;
      
      n = expand_name(rname, type, cp, msg, eom, dname);
      if (n < 0)
	break;
      doprintf((" %s", pr_name(dname)));
      cp += n;
      break;
      
    case T_CERT:
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      doprintf(("\t%s", dtoa(n)));
      cp += INT16SZ;
      
      if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
	break;
      n = _getshort(cp);
      doprintf((" %s", dtoa(n)));
      cp += INT16SZ;
      
      if (check_size(rname, type, cp, msg, eor, 1) < 0)
	break;
      n = *cp++;
      doprintf((" %s", dtoa(n)));
      
      if (cp < eor) {
	register char *buf;
	register int size;
	
	n = eor - cp;
	buf = base_ntoa(cp, n);
	size = strlength(buf);
	cp += n;
	
	doprintf((" ("));
	while ((n = (size > 64) ? 64 : size) > 0) {
	  doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
	  buf += n; size -= n;
	}
	doprintf(("\n\t\t\t)"));
      }
      break;

    case T_EID:
      failwith("EID not implemented");
      break;

    case T_NIMLOC:
      failwith("NIMLOC not implemented");
      break;

    case T_ATMA:
      failwith("ATMA not implemented");

      */

    default:
      failwith("unknown RDATA type");
    }

    if(vfields != Val_unit) {
      value vrecord, vrdata, newcons;

      Begin_root(vres);

      vrecord = alloc_small(5, 0);
      Field(vrecord, 0) = copy_string(r_name);
      Field(vrecord, 1) = c_to_mlvariant(rr_type, r_type);
      Field(vrecord, 2) = c_to_mlvariant(rr_class, r_class);
      Field(vrecord, 3) = Val_int(r_ttl);
      vrdata = alloc_small(2, 0);
      Field(vrdata, 0) = c_to_mlvariant(rr_type, r_type);
      Field(vrdata, 1) = vfields;
      Field(vrecord, 4) = vrdata;

      newcons = alloc_small(2, 0);
      Field(newcons, 0) = vrecord;
      Field(newcons, 1) = vres;
      vres = newcons;
      End_roots();
      vrdata = Val_unit;
    }
    cp += r_len;
  }
  return vres;
}
Пример #13
0
CAMLprim value pcre_exec_stub0(
    intnat v_opt, value v_rex, intnat v_pos, intnat v_subj_start, value v_subj,
    value v_ovec, value v_maybe_cof, value v_workspace)
{
  int ret;
  int is_dfa = v_workspace != (value) NULL;
  long
    pos = v_pos,
    len = caml_string_length(v_subj),
    subj_start = v_subj_start;
  long ovec_len = Wosize_val(v_ovec);

  if (pos > len || pos < subj_start)
    caml_invalid_argument("Pcre.pcre_exec_stub: illegal position");

  if (subj_start > len || subj_start < 0)
    caml_invalid_argument("Pcre.pcre_exec_stub: illegal subject start");

  pos -= subj_start;
  len -= subj_start;

  {
    const pcre *code = get_rex(v_rex);  /* Compiled pattern */
    const pcre_extra *extra = get_extra(v_rex);  /* Extra info */
    const char *ocaml_subj =
      String_val(v_subj) + subj_start;  /* Subject string */
    const int opt = v_opt;  /* Runtime options */

    /* Special case when no callout functions specified */
    if (v_maybe_cof == None) {
      int *ovec = (int *) &Field(v_ovec, 0);

      /* Performs the match */
      if (is_dfa)
        ret =
          pcre_dfa_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len,
              (int *) &Field(v_workspace, 0), Wosize_val(v_workspace));
      else
        ret = pcre_exec(code, extra, ocaml_subj, len, pos, opt, ovec, ovec_len);

      if (ret < 0) handle_exec_error("pcre_exec_stub", ret);
      else handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
    }

    /* There are callout functions */
    else {
      value v_cof = Field(v_maybe_cof, 0);
      value v_substrings;
      char *subj = caml_stat_alloc(sizeof(char) * len);
      int *ovec = caml_stat_alloc(sizeof(int) * ovec_len);
      int workspace_len;
      int *workspace;
      struct cod cod = { 0, (value *) NULL, (value *) NULL, (value) NULL };
      struct pcre_extra new_extra =
#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
# ifdef PCRE_EXTRA_MARK
#  ifdef PCRE_EXTRA_EXECUTABLE_JIT
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL, NULL };
#  else
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0, NULL };
#  endif
# else
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
# endif
#else
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif

      cod.subj_start = subj_start;
      memcpy(subj, ocaml_subj, len);

      Begin_roots4(v_rex, v_cof, v_substrings, v_ovec);
        Begin_roots1(v_subj);
          v_substrings = caml_alloc_small(2, 0);
        End_roots();

        Field(v_substrings, 0) = v_subj;
        Field(v_substrings, 1) = v_ovec;

        cod.v_substrings_p = &v_substrings;
        cod.v_cof_p = &v_cof;
        new_extra.callout_data = &cod;

        if (extra != NULL) {
          new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
          new_extra.study_data = extra->study_data;
          new_extra.match_limit = extra->match_limit;
          new_extra.tables = extra->tables;
#ifdef PCRE_EXTRA_MATCH_LIMIT_RECURSION
          new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif
        }

        if (is_dfa) {
          workspace_len = Wosize_val(v_workspace);
          workspace = caml_stat_alloc(sizeof(int) * workspace_len);
          ret =
            pcre_dfa_exec(code, extra, subj, len, pos, opt, ovec, ovec_len,
                (int *) &Field(v_workspace, 0), workspace_len);
        } else
          ret =
            pcre_exec(code, &new_extra, subj, len, pos, opt, ovec, ovec_len);

        caml_stat_free(subj);
      End_roots();

      if (ret < 0) {
        if (is_dfa) caml_stat_free(workspace);
        caml_stat_free(ovec);
        if (ret == PCRE_ERROR_CALLOUT) caml_raise(cod.v_exn);
        else handle_exec_error("pcre_exec_stub(callout)", ret);
      } else {
        handle_pcre_exec_result(ovec, v_ovec, ovec_len, subj_start, ret);
        if (is_dfa) {
          caml_int_ptr ocaml_workspace_dst =
            (caml_int_ptr) &Field(v_workspace, 0);
          const int *workspace_src = workspace;
          const int *workspace_src_stop = workspace + workspace_len;
          while (workspace_src != workspace_src_stop) {
            *ocaml_workspace_dst = *workspace_src;
            ocaml_workspace_dst++;
            workspace_src++;
          }
          caml_stat_free(workspace);
        }
        caml_stat_free(ovec);
      }
    }
  }

  return Val_unit;
}

CAMLprim value pcre_exec_stub(
    intnat v_opt, value v_rex, intnat v_pos, intnat v_subj_start, value v_subj,
    value v_ovec, value v_maybe_cof)
{
  return pcre_exec_stub0(v_opt, v_rex, v_pos, v_subj_start, v_subj,
                         v_ovec, v_maybe_cof, (value) NULL);
}

/* Byte-code hook for pcre_exec_stub
   Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
  return
    pcre_exec_stub0(
        Int_val(argv[0]), argv[1], Int_val(argv[2]), Int_val(argv[3]),
        argv[4], argv[5], argv[6], (value) NULL);
}

/* Byte-code hook for pcre_dfa_exec_stub
   Needed, because there are more than 5 arguments */
CAMLprim value pcre_dfa_exec_stub_bc(value *argv, int __unused argn)
{
  return
    pcre_exec_stub0(
        Int_val(argv[0]), argv[1], Int_val(argv[2]), Int_val(argv[3]),
        argv[4], argv[5], argv[6], argv[7]);
}

static struct custom_operations tables_ops = {
  "pcre_ocaml_tables",
  pcre_dealloc_tables,
  custom_compare_default,
  custom_hash_default,
  custom_serialize_default,
  custom_deserialize_default,
  custom_compare_ext_default
};

/* Generates a new set of chartables for the current locale (see man
   page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
  /* GC will do a full cycle every 1_000_000 table set allocations (one
     table set consumes 864 bytes -> maximum of 864_000_000 bytes unreclaimed
     table sets) */
  const value v_tables =
    caml_alloc_custom(
        &tables_ops, sizeof(struct pcre_ocaml_tables), 1, 1000000);
  set_tables(v_tables, pcre_maketables());
  return v_tables;
}

/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
  return Val_bool(isspace(Int_val(v_c)));
}


/* Returns number of substring associated with a name */

CAMLprim intnat pcre_get_stringnumber_stub(value v_rex, value v_name)
{
  const int ret = pcre_get_stringnumber(get_rex(v_rex), String_val(v_name));
  if (ret == PCRE_ERROR_NOSUBSTRING)
    caml_invalid_argument("Named string not found");

  return ret;
}

CAMLprim value pcre_get_stringnumber_stub_bc(value v_rex, value v_name)
{
  return Val_int(pcre_get_stringnumber_stub(v_rex, v_name));
}


/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
  CAMLparam0();
  CAMLlocal1(v_res);
  int name_count;
  int entry_size;
  const char *tbl_ptr;
  int i;

  int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
  if (ret != 0) raise_internal_error("pcre_names_stub: namecount");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
  if (ret != 0) raise_internal_error("pcre_names_stub: nameentrysize");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
  if (ret != 0) raise_internal_error("pcre_names_stub: nametable");

  v_res = caml_alloc(name_count, 0);

  for (i = 0; i < name_count; ++i) {
    value v_name = caml_copy_string(tbl_ptr + 2);
    Store_field(v_res, i, v_name);
    tbl_ptr += entry_size;
  }

  CAMLreturn(v_res);
}

/* Generic stub for getting integer results from pcre_config */
static inline int pcre_config_int(int what)
{
  int ret;
  pcre_config(what, (void *) &ret);
  return ret;
}

/* Generic stub for getting long integer results from pcre_config */
static inline int pcre_config_long(int what)
{
  long ret;
  pcre_config(what, (void *) &ret);
  return ret;
}
Пример #14
0
/* Executes a pattern match with runtime options, a regular expression, a
   string offset, a string length, a subject string, a number of subgroup
   offsets, an offset vector and an optional callout function */
CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs,
                              value v_subj, value v_subgroups2, value v_ovec,
                              value v_maybe_cof)
{
  const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj);

  if (ofs > len || ofs < 0)
    caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset");

  {
    const pcre *code = (pcre *) Field(v_rex, 1);  /* Compiled pattern */
    const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);  /* Extra info */
    const char *ocaml_subj = String_val(v_subj);  /* Subject string */
    const int opt = Int_val(v_opt);  /* Runtime options */
    int subgroups2 = Int_val(v_subgroups2);
    const int subgroups2_1 = subgroups2 - 1;
    const int subgroups3 = (subgroups2 >> 1) + subgroups2;

    /* Special case when no callout functions specified */
    if (v_maybe_cof == None) {
      int *ovec = (int *) &Field(v_ovec, 0);

      /* Performs the match */
      const int ret =
        pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3);

      if (ret < 0) {
        switch(ret) {
          case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
          case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
          case PCRE_ERROR_MATCHLIMIT :
            caml_raise_constant(*pcre_exc_MatchLimit);
          case PCRE_ERROR_BADPARTIAL :
            caml_raise_constant(*pcre_exc_BadPartial);
          case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
          case PCRE_ERROR_BADUTF8_OFFSET :
            caml_raise_constant(*pcre_exc_BadUTF8Offset);
          default :
            caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
        }
      }

      else {
        const int *ovec_src = ovec + subgroups2_1;
        long int *ovec_dst = (long int *) ovec + subgroups2_1;

        /* Converts offsets from C-integers to OCaml-Integers
           This is a bit tricky, because there are 32- and 64-bit platforms
           around and OCaml chooses the larger possibility for representing
           integers when available (also in arrays) - not so the PCRE */
        while (subgroups2--) {
          *ovec_dst = Val_int(*ovec_src);
          --ovec_src; --ovec_dst;
        }
      }
    }

    /* There are callout functions */
    else {
      value v_cof = Field(v_maybe_cof, 0);
      value v_substrings;
      char *subj = caml_stat_alloc(sizeof(char) * len);
      int *ovec = caml_stat_alloc(sizeof(int) * subgroups3);
      int ret;
      struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL };
      struct pcre_extra new_extra =
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
#else
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif

      memcpy(subj, ocaml_subj, len);

      Begin_roots3(v_rex, v_cof, v_substrings);
        Begin_roots2(v_subj, v_ovec);
          v_substrings = caml_alloc_small(2, 0);
        End_roots();

        Field(v_substrings, 0) = v_subj;
        Field(v_substrings, 1) = v_ovec;

        cod.v_substrings_p = &v_substrings;
        cod.v_cof_p = &v_cof;
        new_extra.callout_data = &cod;

        if (extra == NULL) {
          ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
                          subgroups3);
        }
        else {
          new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
          new_extra.study_data = extra->study_data;
          new_extra.match_limit = extra->match_limit;
          new_extra.tables = extra->tables;
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
          new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif

          ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
                          subgroups3);
        }

        free(subj);
      End_roots();

      if (ret < 0) {
        free(ovec);
        switch(ret) {
          case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
          case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
          case PCRE_ERROR_MATCHLIMIT :
            caml_raise_constant(*pcre_exc_MatchLimit);
          case PCRE_ERROR_BADPARTIAL :
            caml_raise_constant(*pcre_exc_BadPartial);
          case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
          case PCRE_ERROR_BADUTF8_OFFSET :
            caml_raise_constant(*pcre_exc_BadUTF8Offset);
          case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn);
          default :
            caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
        }
      }

      else {
        int *ovec_src = ovec + subgroups2_1;
        long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1;

        while (subgroups2--) {
          *ovec_dst = Val_int(*ovec_src);
          --ovec_src; --ovec_dst;
        }

        free(ovec);
      }
    }
  }

  return Val_unit;
}

/* Byte-code hook for pcre_exec_stub
   Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
  return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
                        argv[4], argv[5], argv[6]);
}

/* Generates a new set of chartables for the current locale (see man
   page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
  /* GC will do a full cycle every 100 table set allocations
     (one table set consumes 864 bytes -> maximum of 86400 bytes
     unreclaimed table sets) */
  const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400);
  Field(v_res, 1) = (value) pcre_maketables();
  return v_res;
}

/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
  return Val_bool(isspace(Int_val(v_c)));
}

/* Returns number of substring associated with a name */
CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
{
  const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
                                        String_val(v_name));
  if (ret == PCRE_ERROR_NOSUBSTRING)
    caml_invalid_argument("Named string not found");

  return Val_int(ret);
}

/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
  CAMLparam0();
  CAMLlocal1(v_res);
  int name_count;
  int entry_size;
  const char *tbl_ptr;
  int i;

  int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  v_res = caml_alloc(name_count, 0);

  for (i = 0; i < name_count; ++i) {
    value v_name = caml_copy_string(tbl_ptr + 2);
    Store_field(v_res, i, v_name);
    tbl_ptr += entry_size;
  }

  CAMLreturn(v_res);
}
Пример #15
0
CAMLexport value
unix_getsockopt_aux(char * name,
                    enum option_type ty, int level, int option,
                    value socket)
{
    union option_value optval;
    socklen_param_type optsize;


    switch (ty) {
    case TYPE_BOOL:
    case TYPE_INT:
    case TYPE_UNIX_ERROR:
        optsize = sizeof(optval.i);
        break;
    case TYPE_LINGER:
        optsize = sizeof(optval.lg);
        break;
    case TYPE_TIMEVAL:
        optsize = sizeof(optval.tv);
        break;
    default:
        unix_error(EINVAL, name, Nothing);
    }

    if (getsockopt(Int_val(socket), level, option,
                   (void *) &optval, &optsize) == -1)
        uerror(name, Nothing);

    switch (ty) {
    case TYPE_BOOL:
        return Val_bool(optval.i);
    case TYPE_INT:
        return Val_int(optval.i);
    case TYPE_LINGER:
        if (optval.lg.l_onoff == 0) {
            return Val_int(0);        /* None */
        } else {
            value res = alloc_small(1, 0); /* Some */
            Init_field(res, 0, Val_int(optval.lg.l_linger));
            return res;
        }
    case TYPE_TIMEVAL:
        return copy_double((double) optval.tv.tv_sec
                           + (double) optval.tv.tv_usec / 1e6);
    case TYPE_UNIX_ERROR:
        if (optval.i == 0) {
            return Val_int(0);        /* None */
        } else {
            value err, res;
            err = unix_error_of_code(optval.i);
            Begin_root(err);
            res = alloc_small(1, 0); /* Some */
            Init_field(res, 0, err);
            End_roots();
            return res;
        }
    default:
        unix_error(EINVAL, name, Nothing);
    }
}
Пример #16
0
static void
uwt_udp_recv_own_cb(uv_udp_t* handle,
                    ssize_t nread,
                    const uv_buf_t* buf,
                    const struct sockaddr* addr,
                    unsigned int flags)
{
  HANDLE_CB_INIT_WITH_CLEAN(uh, handle);
  value exn = Val_unit;
#ifndef UWT_NO_COPY_READ
  bool buf_not_cleaned = true;
  const int read_ba = uh->use_read_ba;
#else
  (void) buf;
#endif
  if ( uh->close_called == 0 && (nread != 0 || addr != NULL) ){
    /* nread == 0 && addr == NULL only means we need to clear
       the buffer */
    assert ( uh->cb_read != CB_INVALID );
    value param;
    if ( nread < 0 ){
      param = caml_alloc_small(1,Error_tag);
      Field(param,0) = Val_uwt_error(nread);
    }
    else {
      value triple = Val_unit;
      value sockaddr = Val_unit;
      param = Val_unit;
      Begin_roots3(triple,sockaddr,param);
      value is_partial;
      if ( addr != NULL ){
        param = uwt__alloc_sockaddr(addr);
        if ( param != Val_unit ){
          sockaddr = caml_alloc_small(1,Some_tag);
          Field(sockaddr,0) = param;
        }
      }
      if ( flags & UV_UDP_PARTIAL ){
        is_partial = Val_long(1);
      }
      else {
        is_partial = Val_long(0);
      }
#ifndef UWT_NO_COPY_READ
      if ( nread != 0 && read_ba == 0 ){
        value o = Field(GET_CB_VAL(uh->cb_read),0);
        memcpy(String_val(o) + uh->x.obuf_offset, buf->base, nread);
      }
#endif
      triple = caml_alloc_small(3,0);
      Field(triple,0) = Val_long(nread);
      Field(triple,1) = is_partial;
      Field(triple,2) = sockaddr;
      param = caml_alloc_small(1,Ok_tag);
      Field(param,0) = triple;
      End_roots();
    }
#ifndef UWT_NO_COPY_READ
    if ( buf->base && read_ba == 0 ){
      buf_not_cleaned = false;
      uwt__free_uv_buf_t_const(buf);
    }
#endif
    uh->can_reuse_cb_read = 1;
    uh->read_waiting = 0;
    uh->in_use_cnt--;
    exn = Field(GET_CB_VAL(uh->cb_read),1);
    uwt__gr_unregister(&uh->cb_read);
    exn = caml_callback2_exn(*uwt__global_wakeup,exn,param);
    if ( uh->close_called == 0 && uh->can_reuse_cb_read == 1 ){
      uv_udp_recv_stop(handle);
      uh->can_reuse_cb_read = 0;
    }
  }
#ifndef UWT_NO_COPY_READ
  if ( read_ba == 0 && buf_not_cleaned && buf->base ){
    uwt__free_uv_buf_t_const(buf);
  }
#endif
  HANDLE_CB_RET(exn);
}