void caml_execute_signal(int signal_number, int in_signal_handler)
{
value res;
#ifdef POSIX_SIGNALS
sigset_t sigs;
/* Block the signal before executing the handler, and record in sigs
the original signal mask */
sigemptyset(&sigs);
sigaddset(&sigs, signal_number);
sigprocmask(SIG_BLOCK, &sigs, &sigs);
#endif
res = caml_callback_exn(
Field(caml_signal_handlers, signal_number),
Val_int(caml_rev_convert_signal_number(signal_number)));
#ifdef POSIX_SIGNALS
if (! in_signal_handler) {
/* Restore the original signal mask */
sigprocmask(SIG_SETMASK, &sigs, NULL);
} else if (Is_exception_result(res)) {
/* Restore the original signal mask and unblock the signal itself */
sigdelset(&sigs, signal_number);
sigprocmask(SIG_SETMASK, &sigs, NULL);
}
#endif
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
}
CAMLprim value caml_sqlite3_exec(value v_db, value v_maybe_cb, value v_sql)
{
CAMLparam1(v_db);
CAMLlocal2(v_cb, v_exn);
callback_with_exn cbx;
db_wrap *dbw = Sqlite3_val(v_db);
int len = caml_string_length(v_sql) + 1;
char *sql;
int rc;
sqlite3_callback cb = NULL;
check_db(dbw, "exec");
sql = caml_stat_alloc(len);
memcpy(sql, String_val(v_sql), len);
cbx.cbp = &v_cb;
cbx.exn = &v_exn;
if (v_maybe_cb != Val_None) {
v_cb = Field(v_maybe_cb, 0);
cb = exec_callback;
}
caml_enter_blocking_section();
rc = sqlite3_exec(dbw->db, sql, cb, (void *) &cbx, NULL);
free(sql);
caml_leave_blocking_section();
if (rc == SQLITE_ABORT) caml_raise(*cbx.exn);
CAMLreturn(Val_rc(rc));
}
CAMLexport value caml_callback3 (value closure, value arg1, value arg2,
value arg3)
{
value res = caml_callback3_exn(closure, arg1, arg2, arg3);
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
return res;
}
CAMLexport void caml_raise_out_of_memory(void)
{
if (out_of_memory_bucket.exn == 0)
caml_fatal_error
("Fatal error: out of memory while raising Out_of_memory\n");
caml_raise((value) &(out_of_memory_bucket.exn));
}
CAMLprim value caml_sqlite3_exec_not_null_no_headers(
value v_db, value v_cb, value v_sql)
{
CAMLparam2(v_db, v_cb);
CAMLlocal1(v_exn);
callback_with_exn cbx;
db_wrap *dbw = Sqlite3_val(v_db);
int len = caml_string_length(v_sql) + 1;
char *sql;
int rc;
check_db(dbw, "exec_not_null_no_headers");
sql = caml_stat_alloc(len);
memcpy(sql, String_val(v_sql), len);
cbx.cbp = &v_cb;
cbx.exn = &v_exn;
caml_enter_blocking_section();
rc =
sqlite3_exec(
dbw->db, sql, exec_not_null_no_headers_callback, (void *) &cbx, NULL);
free(sql);
caml_leave_blocking_section();
if (rc == SQLITE_ABORT) {
if (*cbx.exn != 0) caml_raise(*cbx.exn);
else raise_sqlite3_Error("Null element in row");
}
CAMLreturn(Val_rc(rc));
}
CAMLexport void caml_raise_constant(value tag)
{
#ifndef NATIVE_CODE
if( bytecode_compatibility == Caml1999X008){
Caml1999X008_caml_raise_constant(tag);
} else
#endif
caml_raise(tag);
}
CAMLexport void caml_raise_constant(value tag)
{
CAMLparam1 (tag);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (1, 0);
Field(bucket, 0) = tag;
caml_raise(bucket);
CAMLnoreturn;
}
/* Raises the Brlapi_error exception */
static void raise_brlapi_error(void)
{
static value *exception = NULL;
CAMLlocal1(res);
if (exception==NULL) exception = caml_named_value("Brlapi_error");
res = caml_alloc(2,0);
Store_field(res, 0, *exception);
Store_field(res, 1, constrCamlError(&brlapi_error));
caml_raise(res);
}
static inline void raise_with_two_args(value v_tag, value v_arg1, value v_arg2)
{
CAMLparam3(v_tag, v_arg1, v_arg2);
value v_exc = caml_alloc_small(3, 0);
Field(v_exc, 0) = v_tag;
Field(v_exc, 1) = v_arg1;
Field(v_exc, 2) = v_arg2;
caml_raise(v_exc);
CAMLnoreturn;
}
value
guestfs_int_mllib_visit (value gv, value dirv, value fv)
{
CAMLparam3 (gv, dirv, fv);
value *visit_failure_exn;
guestfs_h *g = (guestfs_h *) (intptr_t) Int64_val (gv);
struct visitor_function_wrapper_args args;
/* The dir string could move around when we call the
* visitor_function, so we have to take a full copy of it.
*/
char *dir = strdup (String_val (dirv));
/* This stack address is used to point to the exception, if one is
* raised in the visitor_function.
*/
CAMLlocal1 (exn);
exn = Val_unit;
args.exnp = &exn;
args.fvp = &fv;
if (visit (g, dir, visitor_function_wrapper, &args) == -1) {
free (dir);
if (exn != Val_unit) {
/* The failure was caused by visitor_function raising an
* exception. Re-raise it here.
*/
caml_raise (exn);
}
/* Otherwise it's some other failure. The visit function has
* already printed the error to stderr (XXX - fix), so we raise a
* generic exception.
*/
visit_failure_exn = caml_named_value ("Visit.Failure");
caml_raise (*visit_failure_exn);
}
free (dir);
CAMLreturn (Val_unit);
}
void caml_raise_with_arg(value tag, value arg)
{
CAMLparam2 (tag, arg);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (2, 0);
caml_initialize_field(bucket, 0, tag);
caml_initialize_field(bucket, 1, arg);
caml_raise(bucket);
CAMLnoreturn;
}
static inline tcp_wrap *
tcp_wrap_of_value(value v_tw)
{
struct tcp_wrap *tw = Tcp_wrap_val(v_tw);
if (tw->pcb == NULL) {
LWIP_STUB_DPRINTF("tcp_wrap_finalize: CLOSED");
caml_raise(*Lwip_Connection_closed);
}
LWIP_STUB_DPRINTF("tcp_wrap_finalize: ok");
return tw;
}
CAMLexport void caml_raise_with_arg(value tag, value arg)
{
CAMLparam2 (tag, arg);
CAMLlocal1 (bucket);
bucket = caml_alloc_small (2, 0);
Field(bucket, 0) = tag;
Field(bucket, 1) = arg;
caml_raise(bucket);
CAMLnoreturn;
}
void caml_array_bound_error(void)
{
if (caml_array_bound_error_exn == NULL) {
caml_array_bound_error_exn =
caml_named_value("Pervasives.array_bound_error");
if (caml_array_bound_error_exn == NULL) {
fprintf(stderr, "Fatal error: exception "
"Invalid_argument(\"index out of bounds\")\n");
exit(2);
}
}
caml_raise(*caml_array_bound_error_exn);
}
void caml_array_bound_error(void)
{
caml_root array_bound_error_exn;
array_bound_error_exn =
caml_named_root("Pervasives.array_bound_error");
if (!array_bound_error_exn) {
fprintf(stderr, "Fatal error: exception "
"Invalid_argument(\"index out of bounds\")\n");
exit(2);
}
caml_raise(caml_read_root(array_bound_error_exn));
}
CAMLexport void caml_raise_with_args(value tag, int nargs, value args[])
{
CAMLparam1 (tag);
CAMLxparamN (args, nargs);
value bucket;
int i;
Assert(1 + nargs <= Max_young_wosize);
bucket = caml_alloc_small (1 + nargs, 0);
Field(bucket, 0) = tag;
for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];
caml_raise(bucket);
CAMLnoreturn;
}
void caml_raise_with_args(value tag, int nargs, value args[])
{
CAMLparam1 (tag);
CAMLxparamN (args, nargs);
CAMLlocal1 (bucket);
int i;
bucket = caml_alloc (1 + nargs, 0);
caml_initialize_field(bucket, 0, tag);
for (i = 0; i < nargs; i++)
caml_initialize_field(bucket, 1 + i, args[i]);
caml_raise(bucket);
CAMLnoreturn;
}
/* Raises exceptions which take two arguments */
static void raise_with_two_args(value tag, value arg1, value arg2)
{
value v_exc;
/* Protects tag, arg1 and arg2 from being reclaimed by the garbage
collector when the exception value is allocated */
Begin_roots3(tag, arg1, arg2);
v_exc = caml_alloc_small(3, 0);
Field(v_exc, 0) = tag;
Field(v_exc, 1) = arg1;
Field(v_exc, 2) = arg2;
End_roots();
caml_raise(v_exc);
}
/* Raises Brlapi_exception */
static void BRLAPI_STDCALL raise_brlapi_exception(int err, brlapi_packetType_t type, const void *packet, size_t size)
{
static value *exception = NULL;
int i;
CAMLlocal2(str, res);
str = caml_alloc_string(size);
for (i=0; i<size; i++) Byte(str, i) = ((char *) packet)[i];
if (exception==NULL) exception = caml_named_value("Brlapi_exception");
res = caml_alloc (4, 0);
Store_field(res, 0, *exception);
Store_field(res, 1, Val_int(err));
Store_field(res, 2, caml_copy_int32(type));
Store_field(res, 3, str);
caml_raise(res);
}
void caml_array_bound_error(void)
{
if (! array_bound_error_bucket_inited) {
mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value);
mlsize_t offset_index = Bsize_wsize(wosize) - 1;
array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white);
array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN;
array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white);
array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument;
array_bound_error_bucket.arg = (value) array_bound_error_msg.data;
array_bound_error_bucket_inited = 1;
caml_page_table_add(In_static_data,
&array_bound_error_msg,
&array_bound_error_msg + 1);
array_bound_error_bucket_inited = 1;
}
caml_raise((value) &array_bound_error_bucket.exn);
}
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)
caml_invalid_argument("Exception Zlib.Error not initialized");
}
Begin_roots3(s1, s2, bucket);
s1 = caml_copy_string(fn);
s2 = caml_copy_string(msg);
bucket = caml_alloc_small(3, 0);
Field(bucket, 0) = *camlzip_error_exn;
Field(bucket, 1) = s1;
Field(bucket, 2) = s2;
End_roots();
caml_raise(bucket);
}
value hdf5_h5l_iterate_by_name(value loc_v, value group_name_v, value index_type_v,
value order_v, value idx_v, value op_v, value lapl_v, value op_data_v)
{
CAMLparam5(loc_v, group_name_v, index_type_v, order_v, idx_v);
CAMLxparam3(op_v, lapl_v, op_data_v);
CAMLlocal1(exception);
struct operator_data op_data;
hsize_t idx, ret;
op_data.callback = &op_v;
op_data.operator_data = &op_data_v;
op_data.exception = &exception;
idx = Is_block(idx_v) ? Int_val(Field(Field(idx_v, 0), 0)) : 0;
exception = Val_unit;
ret = H5Literate_by_name(Hid_val(loc_v), String_val(group_name_v),
H5_index_val(index_type_v), H5_iter_order_val(order_v),
Is_block(idx_v) ? &idx : NULL, hdf5_h5l_operator, &op_data, H5P_opt_val(lapl_v));
if (Is_block(idx_v))
Store_field(Field(idx_v, 0), 0, Val_int(idx));
if (exception != Val_unit)
caml_raise(exception);
CAMLreturn(Val_h5_iter(ret));
}
value
guestfs_int_mllib_visit (value gv, value dirv, value fv)
{
CAMLparam3 (gv, dirv, fv);
guestfs_h *g = (guestfs_h *) Int64_val (gv);
struct visitor_function_wrapper_args args;
/* The dir string could move around when we call the
* visitor_function, so we have to take a full copy of it.
*/
CLEANUP_FREE char *dir = strdup (String_val (dirv));
/* This stack address is used to point to the exception, if one is
* raised in the visitor_function. Note that the macro initializes
* this to Val_unit, which is how we know if an exception was set.
*/
CAMLlocal1 (exn);
args.exnp = &exn;
args.fvp = &fv;
if (visit (g, dir, visitor_function_wrapper, &args) == -1) {
if (exn != Val_unit) {
/* The failure was caused by visitor_function raising an
* exception. Re-raise it here.
*/
caml_raise (exn);
}
/* Otherwise it's some other failure. The visit function has
* already printed the error to stderr (XXX - fix), so we raise a
* generic Failure.
*/
caml_failwith ("visit");
}
CAMLreturn (Val_unit);
}
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;
}
void caml_raise_out_of_memory(void)
{
caml_raise((value) &caml_bucket_Out_of_memory);
}
void caml_raise_stack_overflow(void)
{
caml_raise((value) &caml_bucket_Stack_overflow);
}
void caml_raise_constant(value tag)
{
caml_raise(tag);
}
CAMLexport value caml_callbackN (value closure, int narg, value args[])
{
value res = caml_callbackN_exn(closure, narg, args);
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
return res;
}
/* 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);
}
