static value Val_context(const char *context)
{
	if (context == NULL)
		return Val_none;
	return Val_some(caml_copy_string(context));
}
Example #2
0
CAMLprim value caml_sqlite3_errmsg(value v_db)
{
  db_wrap *dbw = Sqlite3_val(v_db);
  check_db(dbw, "errmsg");
  return caml_copy_string(sqlite3_errmsg(dbw->db));
}
Example #3
0
CAMLprim value get_real_path( value path ) {
#ifdef _WIN32
	const char sep = '\\';
	size_t len, i, last;
	WIN32_FIND_DATA data;
	HANDLE handle;
	char out[MAX_PATH];

	// this will ensure the full class path with proper casing
	if( GetFullPathName(String_val(path),MAX_PATH,out,NULL) == 0 )
		failwith("get_real_path");

	len = strlen(out);
	i = 0;

	if (len >= 2 && out[1] == ':') {
		// convert drive letter to uppercase
		if (out[0] >= 'a' && out[0] <= 'z')
			out[0] += 'A' - 'a';
		if (len >= 3 && out[2] == sep)
			i = 3;
		else
			i = 2;
	}

	last = i;

	while (i < len) {
		// skip until separator
		while (i < len && out[i] != sep)
			i++;

		// temporarily strip string to last found component
		out[i] = 0;

		// get actual file/dir name with proper case
		if ((handle = FindFirstFile(out, &data)) != INVALID_HANDLE_VALUE) {
			int klen = strlen(data.cFileName);
			// a ~ was expanded !
			if( klen != i - last ) {
				int d = klen - (i - last);
				memmove(out + i + d, out + i, len - i + 1);
				len += d;
				i += d;
			}
			// replace the component with proper case
			memcpy(out + last, data.cFileName, klen + 1);
			FindClose(handle);
		}

		// if we're not at the end, restore the path
		if (i < len)
			out[i] = sep;

		// advance
		i++;
		last = i;
	}

	return caml_copy_string(out);
#else
	return path;
#endif
}
Example #4
0
CAMLextern_C value
caml_sfHttpResponse_getBody(value httpResponse)
{
    const std::string& resp = SfHttpResponse_val(httpResponse)->getBody();
    return caml_copy_string(resp.c_str());
}
CAMLprim value ocaml_plugin_archive (value unit __attribute__ ((unused)))
{
  char v[] = "dummy";

  return(caml_copy_string(v));
}
Example #6
0
/* Target.t -> string */
CAMLprim value llvm_target_description(LLVMTargetRef Target) {
  return caml_copy_string(LLVMGetTargetDescription(Target));
}
CAMLprim value mmdb_ml_version(void)
{
  return caml_copy_string(MMDB_lib_version());
}
Example #8
0
value alpm_to_caml_strelem ( void * elem )
{
    CAMLparam0();
    CAMLreturn( caml_copy_string( (char *) elem ));
}
Example #9
0
void caml_raise_with_string(value tag, char const *msg)
{
  caml_raise_with_arg(tag, caml_copy_string(msg));
}
Example #10
0
CAMLprim value
iface_name(value ifap)
{
  return caml_copy_string(((struct ifaddrs *)ifap)->ifa_name);
}
Example #11
0
/* alloc */
value bap_disasm_backend_name_stub(value n) {
    CAMLparam1(n);
    CAMLlocal1(s);
    s = caml_copy_string(bap_disasm_backend_name(Int_val(n)));
    CAMLreturn(s);
}
Example #12
0
void lwt_unix_not_available(char const *feature) {
  caml_raise_with_arg(*caml_named_value("lwt:not-available"),
                      caml_copy_string(feature));
}
Example #13
0
CAMLprim value
ocaml_get_routing_table(value unit) {
    CAMLparam1(unit);
    CAMLlocal3( ret, tmp, entry );

    struct nl_sock *fd;
    struct nl_cache *res, *links;
    struct rtnl_route *it;
    uint32 i_ip, netmask = 0, mask_len, gw;
    int i;
    struct nl_addr *ip;
    char device_name[IFNAMSIZ];
    struct rtnl_nexthop *to;
    fd = nl_socket_alloc();
    if (!fd) {
        fprintf(stderr, "error nl_socket_alloc\n");
        exit(1);
    }

    if(nl_connect(fd, NETLINK_ROUTE) < 0) {
        fprintf(stderr, "error nl_connect\n");
        exit(1);
    }

    ret = Val_emptylist;

    if(rtnl_route_alloc_cache(fd, AF_UNSPEC, 0, &res) < 0) {
        fprintf(stderr, "error rtnl_route_alloc_cache");
        exit(1);
    }

    if(rtnl_link_alloc_cache (fd, AF_UNSPEC, &links) < 0) {
        fprintf(stderr, "error rtnl_link_alloc_cache");
        exit(1);
    }

    it = (struct rtnl_route *)nl_cache_get_first(res);
    for(; it != NULL; it = (struct rtnl_route *)
                           nl_cache_get_next((struct nl_object *)it) ) {
        if(rtnl_route_get_family (it) == AF_INET) {
            ip = rtnl_route_get_dst(it);
            i_ip = ntohl(*(int *)nl_addr_get_binary_addr(ip));
            mask_len = nl_addr_get_prefixlen(ip);
            for(i = 0; i < 32; i++)
                netmask = (netmask << 1) + (i< mask_len?1:0);
            to = rtnl_route_nexthop_n(it, 0);
            rtnl_link_i2name(links, rtnl_route_nh_get_ifindex(to),
                             device_name, IFNAMSIZ);
            if ( rtnl_route_nh_get_gateway (to) != NULL)
                gw = ntohl(*(int *)nl_addr_get_binary_addr(
                               rtnl_route_nh_get_gateway (to)));
            else
                gw = 0;
            /*printf("src ip:%x mask:%x gw:%x dev:%s\n", i_ip, netmask, */
            /*gw, device_name);*/

            entry = caml_alloc(7,0);
            Store_field(entry, 0, Val_int(i_ip & 0xFFFF));
            Store_field(entry, 1, Val_int(i_ip >> 16));
            Store_field(entry, 2, Val_int(netmask & 0xFFFF));
            Store_field(entry, 3, Val_int(netmask >> 16));
            Store_field(entry, 4, Val_int(gw & 0xFFFF));
            Store_field(entry, 5, Val_int(gw >> 16));
            Store_field(entry, 6, caml_copy_string(device_name));

            // store in list
            tmp =  caml_alloc(2, 0);
            Store_field( tmp, 0, entry);  // head
            Store_field( tmp, 1, ret);  // tail
            ret = tmp;
        }
    }
Example #14
0
File: c_gz.c Project: amnh/poy5
/* get library version */
value mlgz_zlibversion(value unit)
{
  return caml_copy_string(zlibVersion());
}
Example #15
0
CAMLprim value stub_avahi_string_list_get_text(value l)
{
  CAMLparam1(l);
  CAMLreturn(caml_copy_string((const char *)avahi_string_list_get_text((AvahiStringList *)l)));
}
Example #16
0
CAMLprim value
caml_spf_strreason(value reason_val)
{
    CAMLparam1(reason_val);
    CAMLreturn(caml_copy_string(SPF_strreason(Int_val(reason_val))));
}
Example #17
0
/* Target.t -> string */
CAMLprim value llvm_target_name(LLVMTargetRef Target) {
  return caml_copy_string(LLVMGetTargetName(Target));
}
Example #18
0
CAMLprim value ocaml_faad_get_error_message(value err)
{
  return caml_copy_string((char*)NeAACDecGetErrorMessage(Int_val(err)));
}
CAMLprim value mmdb_ml_lookup_path(value ip, value query_list, value mmdb)
{
  CAMLparam3(ip, query_list, mmdb);
  CAMLlocal3(iter_count, caml_clean_result, query_r);

  int total_len = 0, copy_count = 0, gai_error = 0, mmdb_error = 0;
  char *clean_result;
  long int int_result;

  iter_count = query_list;

  unsigned int len = caml_string_length(ip);
  char *as_string = caml_strdup(String_val(ip));
  if (strlen(as_string) != (size_t)len) {
    caml_failwith("Could not copy IP address properly");
  }

  MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb);
  MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result));
  *result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error);
  check_error(gai_error, mmdb_error);
  caml_stat_free(as_string);

  while (iter_count != Val_emptylist) {
    total_len++;
    iter_count = Field(iter_count, 1);
  }

  char **query = caml_stat_alloc(sizeof(char *) * (total_len + 1));

  while (query_list != Val_emptylist) {
    query[copy_count] = caml_strdup(String_val(Field(query_list, 0)));
    copy_count++;
    query_list = Field(query_list, 1);
  }
  query[total_len] = NULL;
  MMDB_entry_data_s entry_data;

  int status = MMDB_aget_value(&result->entry,
			       &entry_data,
			       (const char *const *const)query);
  check_status(status);
  check_data(entry_data);
  caml_stat_free(result);
  for (int i = 0; i < copy_count; caml_stat_free(query[i]), i++);
  caml_stat_free(query);
  query_r = caml_alloc(2, 0);
  as_mmdb = NULL;
  switch (entry_data.type) {
  case MMDB_DATA_TYPE_BYTES:
    clean_result = caml_stat_alloc(entry_data.data_size + 1);
    memcpy(clean_result, entry_data.bytes, entry_data.data_size);
    caml_clean_result = caml_copy_string(clean_result);
    caml_stat_free(clean_result);
    goto string_finish;

  case MMDB_DATA_TYPE_UTF8_STRING:
    clean_result = strndup(entry_data.utf8_string, entry_data.data_size);
    caml_clean_result = caml_copy_string(clean_result);
    free(clean_result);
    goto string_finish;

  case MMDB_DATA_TYPE_FLOAT:
    Store_field(query_r, 0, polymorphic_variants.poly_float);
    Store_field(query_r, 1, caml_copy_double(entry_data.float_value));
    goto finish;

  case MMDB_DATA_TYPE_BOOLEAN:
    Store_field(query_r, 0, polymorphic_variants.poly_bool);
    Store_field(query_r, 1, Val_true ? entry_data.boolean : Val_false);
    goto finish;

  case MMDB_DATA_TYPE_DOUBLE:
    Store_field(query_r, 0, polymorphic_variants.poly_float);
    Store_field(query_r, 1, caml_copy_double(entry_data.double_value));
    goto finish;

  case MMDB_DATA_TYPE_UINT16:
    Store_field(query_r, 0, polymorphic_variants.poly_int);
    int_result = Val_long(entry_data.uint16);
    goto int_finish;

  case MMDB_DATA_TYPE_UINT32:
    Store_field(query_r, 0, polymorphic_variants.poly_int);
    int_result = Val_long(entry_data.uint32);
    goto int_finish;

  case MMDB_DATA_TYPE_UINT64:
    Store_field(query_r, 0, polymorphic_variants.poly_int);
    int_result = Val_long(entry_data.uint32);
    goto int_finish;

    // look at /usr/bin/sed -n 1380,1430p src/maxminddb.c
  case MMDB_DATA_TYPE_ARRAY:
  case MMDB_DATA_TYPE_MAP:
    caml_failwith("Can't return a Map or Array yet");
  }

 string_finish:
  Store_field(query_r, 0, polymorphic_variants.poly_string);
  Store_field(query_r, 1, caml_clean_result);
  CAMLreturn(query_r);

 int_finish:
  Store_field(query_r, 1, int_result);
  CAMLreturn(query_r);

 finish:
  CAMLreturn(query_r);
}
Example #20
0
CAMLprim value getsockopt_stub(value sock, value sockopt) {
    CAMLparam2 (sock, sockopt);
    CAMLlocal1 (result);
    int error = -1;
    int native_sockopt = Int_val(sockopt);
    struct wrap *socket = Socket_val(sock);
    
    switch (native_sockopt) {
        case ZMQ_SNDHWM:
        case ZMQ_RCVHWM:
        case ZMQ_RATE:
        case ZMQ_RECOVERY_IVL:
        case ZMQ_SNDBUF:
        case ZMQ_RCVBUF:
        case ZMQ_LINGER:
        case ZMQ_RECONNECT_IVL:
        case ZMQ_RECONNECT_IVL_MAX:
        case ZMQ_BACKLOG:
        case ZMQ_MULTICAST_HOPS:
        case ZMQ_RCVTIMEO:
        case ZMQ_SNDTIMEO:
        case ZMQ_RCVMORE:
        case ZMQ_RCVLABEL:
        case ZMQ_TYPE:
        {   
            int res;
            size_t size = sizeof(res);
            error = zmq_getsockopt(socket->wrapped, native_sockopt, &res, &size);
            stub_raise_if (error == -1);            
            result = Val_int(res);
        }
        break;

        case ZMQ_AFFINITY:
        case ZMQ_MAXMSGSIZE:
        {
            int64 res;
            size_t size = sizeof(res);
            error = zmq_getsockopt(socket->wrapped, native_sockopt, &res, &size);
            stub_raise_if (error == -1);
            result = caml_copy_int64(res);
        }
        break;

        case ZMQ_EVENTS:
        {
            int res;
            size_t size = sizeof(res);
            error = zmq_getsockopt(socket->wrapped, native_sockopt, &res, &size);
            stub_raise_if (error == -1);            
            result = POOL_LIST_CACHE[res];
        }
        break;
        
        case ZMQ_IDENTITY:
        {
            char buffer[256];
            buffer[255] = '\0';
            size_t size = sizeof(buffer);
            error = zmq_getsockopt(socket->wrapped, native_sockopt, buffer, &size);
            stub_raise_if (error == -1);
            if (size == 0) {
                result = EMPTY_STRING;
            } else {
                result = caml_copy_string(buffer);
            }
        }
        break;            

        case ZMQ_FD:
        {
            #if defined(_WIN32) || defined(_WIN64)
            SOCKET fd;
            #else
            int fd;
            #endif
            size_t size = sizeof (fd);
            error = zmq_getsockopt (socket->wrapped, native_sockopt, (void *) (&fd), &size);
            stub_raise_if (error == -1);
            #if defined(_WIN32) || defined(_WIN64)
            result = win_alloc_socket(fd);
            #else
            result = Val_int(fd);
            #endif
        }
        break;

        default:
            caml_failwith("Bidings error");            

    }
    CAMLreturn (result);
}
value get_adverb(char* adverb_name) {
  CAMLparam0();
  CAMLlocal1(ocaml_adverb_name);
  ocaml_adverb_name = caml_copy_string(adverb_name); 
  CAMLreturn(caml_callback(*ocaml_get_adverb, ocaml_adverb_name));
}
Example #22
0
CAMLprim value libssh_ml_version(void)
{
  return caml_copy_string(SSH_STRINGIFY(LIBSSH_VERSION));
}
Example #23
0
CAMLprim value caml_extunix_recvmsg(value fd_val)
{
  CAMLparam1(fd_val);
  CAMLlocal2(data, res);
  struct msghdr msg;
  int fd = Int_val(fd_val);
  int recvfd;
  ssize_t len;
  struct iovec iov[1];
  char buf[4096];

#if defined(CMSG_SPACE)
  union {
    struct cmsghdr cmsg; /* just for alignment */
    char control[CMSG_SPACE(sizeof recvfd)];
  } control_un;
  struct cmsghdr *cmsgp;

  memset(&msg, 0, sizeof msg);
  msg.msg_control = control_un.control;
  msg.msg_controllen = CMSG_LEN(sizeof recvfd);
#else
  msg.msg_accrights = (caddr_t)&recvfd;
  msg.msg_accrightslen = sizeof recvfd;
#endif

  iov[0].iov_base = buf;
  iov[0].iov_len = sizeof buf;
  msg.msg_iov = iov;
  msg.msg_iovlen = 1;

  caml_enter_blocking_section();
  len = recvmsg(fd, &msg, 0);
  caml_leave_blocking_section();

  if (len == -1)
    uerror("recvmsg", Nothing);

  res = caml_alloc(2, 0);

#if defined(CMSG_SPACE)
  cmsgp = CMSG_FIRSTHDR(&msg);
  if (cmsgp == NULL) {
    Store_field(res, 0, Val_none);
  } else {
    CAMLlocal1(some_fd); 
    if (cmsgp->cmsg_len != CMSG_LEN(sizeof recvfd))
      unix_error(EINVAL, "recvmsg", caml_copy_string("wrong descriptor size"));
    if (cmsgp->cmsg_level != SOL_SOCKET || cmsgp->cmsg_type != SCM_RIGHTS)
      unix_error(EINVAL, "recvmsg", caml_copy_string("invalid protocol"));
    some_fd = caml_alloc(1, 0);
    Store_field(some_fd, 0, Val_int(*(int *)CMSG_DATA(cmsgp)));
    Store_field(res, 0, some_fd);
  }
#else
  if (msg.msg_accrightslen != sizeof recvfd) {
    Store_field(res, 0, Val_none);
  } else {
    CAMLlocal1(some_fd);
    some_fd = caml_alloc(1, 0);
    Store_field(some_fd, 0, Val_int(recvfd));
    Store_field(res, 0, some_fd);
  }
#endif

  data = caml_alloc_string(len);
  memcpy(String_val(data), buf, len);
  Store_field(res, 1, data);

  CAMLreturn (res);
}
Example #24
0
CAMLprim value ocaml_plugin_archive_digest (value unit __attribute__ ((unused)))
{
  return(caml_copy_string("dummy"));
}
Example #25
0
value ml_lua_modinfo (value string) 
{
	CAMLparam1 (string);
	CAMLlocal4 (name, version, depends, tuple);
	int err, i, n;

	lua_State *L = luaL_newstate();
	luaL_openlibs(L);
	err = luaL_dostring (L, String_val(string));
	if (err != 0) {
		caml_failwith("Lua.modinfo");
	}

	name = caml_alloc_string(0);
	version = caml_alloc_string(0);
	depends = caml_alloc_tuple(0);

	lua_pushnil(L);
	while (lua_next(L, -2) != 0) {
		const char *s = lua_tostring(L, -2);

		// Get name string
		if (strcasecmp(s, "name") == 0) { 
			const char *s = lua_tostring(L, -1);
			name = caml_copy_string(s);
		}

		// Get depends array
		else if (strcasecmp(s, "depend") == 0) {
			lua_pushstring(L, "table");
			lua_gettable(L, LUA_GLOBALSINDEX);

			lua_pushstring(L, "getn");
			lua_gettable(L, -2);

			lua_pushvalue(L, -3);
			lua_call(L, 1, 1);
			n = lua_tonumber(L, -1);
			lua_pop(L, 2);

			depends = caml_alloc_tuple(n);

			i = 0;	
			lua_pushnil(L);
			while (lua_next(L, -2) != 0) {
				const char *s = lua_tostring(L, -1);
				Store_field(depends, i, caml_copy_string(s));
				i++;
				lua_pop(L, 1);
			}
		}

		// Get version string
		else if (strcasecmp(s, "version") == 0) {
			const char *s = lua_tostring(L, -1);
			version = caml_copy_string(s);
		}

		lua_pop(L, 1);
	}

	tuple = caml_alloc_tuple(3);
	Store_field(tuple, 0, name);
	Store_field(tuple, 1, version);
	Store_field(tuple, 2, depends);

	CAMLreturn (tuple);
}
Example #26
0
/* Makes OCaml-string from PCRE-version */
CAMLprim value pcre_version_stub(value __unused v_unit)
{
  return caml_copy_string((char *) pcre_version());
}
Example #27
0
static inline value Val_string_option(const char *str)
{ return (str == NULL) ? Val_None : Val_Some(caml_copy_string(str)); }
Example #28
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);
}
Example #29
0
CAMLprim value sys_dlalloc_string( value v ) {
	return caml_copy_string((char*)v);
}
CAMLprim CAMLweakdef value ocaml_plugin_archive_metadata (value unit __attribute__ ((unused)))
{
  return(caml_copy_string(s));
}