unsigned long scandec(char * p, unsigned long max)
{
unsigned long res, d;
int c;
res = 0;
while (1) {
c = *p;
if (c >= '0' && c <= '9') {
d = c - '0';
} else {
break;
}
if ((res > (max/10)) ||
((res == (max/10) && ((max % 10) <= d))) ) {
failwith("scandec");
}
res = 10 * res + d;
p++;
}
if (*p != 0) {
failwith("scandec");
}
return res;
}
value grappa_CAML_better_capping (value c_gene1, value c_gene2, value num_genes)
{
CAMLparam3(c_gene1,c_gene2,num_genes);
int NUM_GENES = Int_val(num_genes);
long dims[1]; dims[0] = NUM_GENES;
struct genome_struct *g1, *g2;
g1 = (struct genome_struct *) Data_custom_val (c_gene1);
g2 = (struct genome_struct *) Data_custom_val (c_gene2);
struct genome_struct * out_genome_list;
out_genome_list = (struct genome_struct *) malloc (sizeof (struct genome_struct) );
if ( out_genome_list == ( struct genome_struct * ) NULL )
failwith ("ERROR: genome_list in grappa_CAML_better_capping is NULL" );
out_genome_list[0].gnamePtr =( char * ) malloc ( MAX_NAME * sizeof ( char ) );
sprintf (out_genome_list[0].gnamePtr, "%i", 0);
if ( out_genome_list[0].gnamePtr == ( char * ) NULL )
failwith( "ERROR: gname of genome_list in grappa_CAML_better_capping is NULL" );
out_genome_list[0].genes =( int * ) malloc ( 3*NUM_GENES * sizeof ( int ) );
out_genome_list[0].delimiters = (int *) malloc (NUM_GENES * sizeof (int) );
out_genome_list[0].magic_number = GRAPPA_MAGIC_NUMBER;
out_genome_list[0].encoding = NULL; //we don't need encoding and gnamePtr;
better_capping (g1->genes,g2->genes,NUM_GENES,g1->delimiters,g2->delimiters,g1->deli_num,g2->deli_num,out_genome_list);
struct genome_arr_t *out_genome_arr;
CAMLlocal1 (c_genome_arr);
c_genome_arr = alloc_custom(&genomeArrOps, sizeof(struct genome_arr_t), 1, 10000);
out_genome_arr = (struct genome_arr_t *) Data_custom_val(c_genome_arr);
out_genome_arr->magic_number = GRAPPA_MAGIC_NUMBER;
out_genome_arr->genome_ptr = out_genome_list;
assert(GRAPPA_MAGIC_NUMBER == out_genome_list[0].magic_number);
out_genome_arr->num_genome = 1;
out_genome_arr->num_gene = NUM_GENES;
CAMLreturn(c_genome_arr);
}
void cpgs_op_vec(const sint *handle, real u[], const sint *n, const sint *op)
{
if(*op<1 || *op>4) failwith("invalid operation to cgps_op_vec");
if(*handle<0 || *handle>=cpgs_n || !cpgs_info[*handle])
failwith("invalid handle to cgps_op_vec");
ogs_op_vec(u,*n,*op,cpgs_info[*handle]);
}
CAMLprim value netsys_fallocate(value fd, value start, value len) {
#ifdef HAVE_POSIX_FALLOCATE
int r;
int64 start_int, len_int;
off_t start_off, len_off;
/* Att: off_t might be 64 bit even on 32 bit systems! */
start_int = Int64_val(start);
len_int = Int64_val(len);
if ( ((int64) ((off_t) start_int)) != start_int )
failwith("Netsys.fadvise: large files not supported on this OS");
if ( ((int64) ((off_t) len_int)) != len_int )
failwith("Netsys.fadvise: large files not supported on this OS");
start_off = start_int;
len_off = len_int;
r = posix_fallocate(Int_val(fd), start_off, len_off);
/* does not set errno! */
if (r != 0)
unix_error(r, "posix_fallocate64", Nothing);
return Val_unit;
#else
invalid_argument("Netsys.fallocate not available");
#endif
}
/* ML type : 6-element record -> dbconn_ */
EXTERNML value mysql_setdb(value args)
{
char* dbhost = StringOrNull_val(Field(args, 0));
char* dbname = StringOrNull_val(Field(args, 1));
char* dboptions = StringOrNull_val(Field(args, 2));
unsigned dbport = (unsigned)(Long_val(Field(args, 3)));
char* dbpwd = StringOrNull_val(Field(args, 4));
char* dbtty = StringOrNull_val(Field(args, 5));
char* dbuser = StringOrNull_val(Field(args, 6));
#if MYSQL_VERSION_ID >= 32200
MYSQL *mysql = mysql_init(NULL);
if (mysql==NULL) {
failwith("mysql_init failed - out of memory");
} else {
MYSQL* newmysql = mysql_real_connect(mysql, dbhost, dbuser, dbpwd,
dbname, dbport, NULL, 0);
if(newmysql==NULL) {
failwith(mysql_error(mysql));
} else {
return (value)(dbconn_alloc(newmysql));
}
}
#else
MYSQL* mysql = mysql_real_connect(NULL, dbhost, dbuser, dbpwd,
dbport, NULL, 0);
if (mysql==NULL) {
failwith("Could not connect");
} else {
if (!mysql_select_db(mysql, dbname))
failwith(mysql_error(mysql));
return (value)(dbconn_alloc(mysql));
}
#endif
}
/* From the gPhoto I/O library */
value c_serial_set_baudrate(value val_fd, value speed)
{
struct termios tio;
int fd = Int_val(val_fd);
if (tcgetattr(fd, &tio) < 0) {
failwith("tcgetattr");
}
tio.c_iflag = 0;
tio.c_oflag = 0;
tio.c_cflag = CS8 | CREAD | CLOCAL;
tio.c_cc[VMIN] = 1;
tio.c_cc[VTIME] = 5;
tio.c_lflag &= ~(ICANON | ISIG | ECHO | ECHONL | ECHOE | ECHOK);
int br = baudrates[Int_val(speed)];
cfsetispeed(&tio, br);
cfsetospeed(&tio, br);
if (tcsetattr(fd, TCSANOW | TCSAFLUSH, &tio) < 0) {
failwith("tcsetattr");
}
return Val_unit;
}
unsigned long scanhex(char * p, unsigned long max)
{
unsigned long res, d;
int c;
res = 0;
while (1) {
c = toupper(*p);
if (c >= '0' && c <= '9') {
d = c - '0';
} else if (c >= 'A' && c <= 'F') {
d = c + (10 - 'A');
} else {
break;
}
if( (res > (max/16)) ||
((res == (max/16) && ((max % 16) <= d))) ) {
failwith("scanhex");
}
res = 16 * res + d;
p++;
}
if (*p != 0) {
failwith("scanhex");
}
return res;
}
CAMLprim value netsys_query_langinfo(value locale)
{
#ifdef HAVE_LOCALE
CAMLparam1(locale);
CAMLlocal1(s);
char *old_locale, *new_locale;
int n, k;
old_locale = setlocale(LC_ALL, NULL);
if (old_locale == NULL)
failwith("Netsys_posix.query_locale: no locale support");
new_locale = setlocale(LC_ALL, String_val(locale));
if (new_locale == NULL)
failwith("Netsys_posix.query_locale: cannot set this locale");
n = sizeof(locale_items_table) / sizeof(locale_items_table[0]);
s = alloc(n,0);
for (k=0; k<n; k++) {
Store_field(s,k,copy_string(nl_langinfo(locale_items_table[k])));
};
setlocale(LC_ALL, old_locale);
CAMLreturn (s);
#else
invalid_argument("Netsys_posix.query_locale not available");
#endif
}
CAMLprim value glyph_to_bitmap(value glyph)
{
CAMLparam1(glyph);
CAMLlocal2(block, buffer);
FT_GlyphSlot slot;
FT_Glyph g;
FT_BitmapGlyph bm;
size_t pitch;
size_t new_pitch;
int i;
slot = *(FT_GlyphSlot *)Data_custom_val(glyph);
if (FT_Get_Glyph(slot, &g))
failwith("glyph_to_bitmap");
if (g->format != FT_GLYPH_FORMAT_BITMAP)
{
if (FT_Glyph_To_Bitmap(&g, FT_RENDER_MODE_MONO, 0, 1))
{
FT_Done_Glyph(g);
failwith("glyph_to_bitmap");
}
}
bm = (FT_BitmapGlyph)g;
pitch = abs(bm->bitmap.pitch);
new_pitch = (bm->bitmap.width + 7) / 8;
block = alloc_tuple(6);
buffer = alloc_string(bm->bitmap.rows * new_pitch);
if (bm->bitmap.pitch >= 0)
{
for (i = 0; i < bm->bitmap.rows; i++)
memcpy(String_val(buffer) + i * new_pitch,
bm->bitmap.buffer + i * pitch,
new_pitch);
}
else
{
for (i = 0; i < bm->bitmap.rows; i++)
memcpy(String_val(buffer) + i * new_pitch,
bm->bitmap.buffer + (bm->bitmap.rows - i) * pitch,
new_pitch);
}
Store_field(block, 0, Val_int(bm->left));
Store_field(block, 1, Val_int(bm->top));
Store_field(block, 2, Val_int(bm->bitmap.rows));
Store_field(block, 3, Val_int(bm->bitmap.width));
Store_field(block, 4, Val_int(new_pitch));
Store_field(block, 5, buffer);
FT_Done_Glyph(g);
CAMLreturn(block);
};
CAMLprim value unix_inet_addr_of_string(value s)
{
#if defined(HAS_IPV6)
#ifdef _WIN32
CAMLparam1(s);
CAMLlocal1(vres);
struct addrinfo hints;
struct addrinfo * res;
int retcode;
memset(&hints, 0, sizeof(hints));
hints.ai_family = AF_UNSPEC;
hints.ai_flags = AI_NUMERICHOST;
retcode = getaddrinfo(String_val(s), NULL, &hints, &res);
if (retcode != 0) failwith("inet_addr_of_string");
switch (res->ai_addr->sa_family) {
case AF_INET:
{
vres =
alloc_inet_addr(&((struct sockaddr_in *) res->ai_addr)->sin_addr);
break;
}
case AF_INET6:
{
vres =
alloc_inet6_addr(&((struct sockaddr_in6 *) res->ai_addr)->sin6_addr);
break;
}
default:
{
freeaddrinfo(res);
failwith("inet_addr_of_string");
}
}
freeaddrinfo(res);
CAMLreturn (vres);
#else
struct in_addr address;
struct in6_addr address6;
if (inet_pton(AF_INET, String_val(s), &address) > 0)
return alloc_inet_addr(&address);
else if (inet_pton(AF_INET6, String_val(s), &address6) > 0)
return alloc_inet6_addr(&address6);
else
failwith("inet_addr_of_string");
#endif
#elif defined(HAS_INET_ATON)
struct in_addr address;
if (inet_aton(String_val(s), &address) == 0)
failwith("inet_addr_of_string");
return alloc_inet_addr(&address);
#else
struct in_addr address;
address.s_addr = inet_addr(String_val(s));
if (address.s_addr == (uint32) -1) failwith("inet_addr_of_string");
return alloc_inet_addr(&address);
#endif
}
/** [chi_pp p v]
* Finds the percentage point [p] of the chi squared distribution of [v] degrees
* of freedom. The gamma is related to this distribution by the define below.
*
* Algorithm AS91: The Percentage Points of the chi^2 Distribution
* (translated to C, and removed goto's ~nrl) */
double chi_pp( double p, double v ){
double ch,s1,s2,s3,s4,s5,s6;
double e,aa,xx,c,g,x,p1,a,q,p2,t,ig,b;
assert( v > 0.0 );
if (p < 0.000002 || p > 0.999998)
failwith("Chi^2 Percentage Points incorrect.1");
e = 0.5e-6; /** error term **/
aa= 0.6931471805;
xx = 0.5 * v;
c = xx - 1.0;
g = lngamma( xx );
if( v < -1.24 * log(p) ){
ch = pow(p * xx * exp ( g + xx * aa), 1.0/xx);
if( ch - e < 0 ) return ch;
} else if( v > 0.32) {
x = point_normal( p );
p1 = 0.222222 / v;
ch = v * pow( x * sqrt( p1 ) + 1 - p1, 3.0) ;
if (ch > 2.2 * v + 6)
ch = -2.0 * (log(1-p) - c*log(0.5*ch)+g);
} else {
ch = 0.4;
a = log (1 - p);
do{
q = ch;
p1 = 1 + ch * (4.67 + ch);
p2 = ch * (6.73 + ch * (6.66 + ch));
t = -0.5 + (4.67 + 2*ch)/p1 - (6.73 + ch*(13.32 + 3*ch))/p2;
ch = ch - (1- exp( a + g + 0.5*ch+c*aa) * p2/p1)/t;
} while( fabs( q/ch - 1) - 0.01 > 0.0 );
}
do{
q = ch;
p1 = .5*ch;
ig = gammap( p1, xx );
if (ig < 0){ failwith("Chi^2 Percentage Points incorrect.2"); }
p2 = p - ig;
t = p2 * exp( xx*aa + g + p1 - c*log(ch));
b = t / ch;
a = (0.5*t) - (b*c);
/* Seven terms of the Taylor series */
s1 = (210 + a*(140 + a*(105 + a*(84 + a*(70 + 60*a))))) / 420.0;
s2 = (420 + a*(735 + a*(966 + a*(1141 + 1278*a)))) / 2520.0;
s3 = (210 + a*(462 + a*(707 + 932*a))) / 2520.0;
s4 = (252 + a*(672 + 1182*a) + c*(294 + a*(889 + 1740*a))) / 5040.0;
s5 = ( 84 + 264*a + c*(175 + 606*a)) / 2520.0;
s6 = (120 + c*(346 + 127*c)) / 5040.0;
ch+= t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
} while( fabs(q / ch - 1.0) > e);
return (ch);
}
void cpgs_op_many(const sint *handle,
real u1[], real u2[], real u3[],
real u4[], real u5[], real u6[],
const sint *n, const sint *op)
{
real *uu[6]={u1,u2,u3,u4,u5,u6};
if(*op<1 || *op>4) failwith("invalid operation to cgps_op_many");
if(*handle<0 || *handle>=cpgs_n || !cpgs_info[*handle])
failwith("invalid handle to cgps_op_many");
ogs_op_many(uu,*n,*op,cpgs_info[*handle]);
}
value int_of_string(value s) /* ML */
{
long res;
int sign;
int base;
char * p;
int c, d;
p = String_val(s);
if (*p == 0) failwith("int_of_string");
sign = 1;
if (*p == '-') {
sign = -1;
p++;
}
base = 10;
if (*p == '0') {
switch (p[1]) {
case 'x':
case 'X':
base = 16;
p += 2;
break;
case 'o':
case 'O':
base = 8;
p += 2;
break;
case 'b':
case 'B':
base = 2;
p += 2;
break;
}
}
res = 0;
while (1) {
c = *p;
if (c >= '0' && c <= '9')
d = c - '0';
else if (c >= 'A' && c <= 'F')
d = c - 'A' + 10;
else if (c >= 'a' && c <= 'f')
d = c - 'a' + 10;
else
break;
if (d >= base) break;
res = base * res + d;
p++;
}
if (*p != 0)
failwith("int_of_string");
return Val_long(sign < 0 ? -res : res);
}
CAMLprim value netsys_ioprio_get(value target) {
#ifdef ioprio_supported
int ioprio;
int ioprio_class;
int ioprio_data;
value result;
switch (Tag_val(target)) {
case 0:
ioprio = ioprio_get(IOPRIO_WHO_PROCESS, Int_val(Field(target, 0)));
break;
case 1:
ioprio = ioprio_get(IOPRIO_WHO_PGRP, Int_val(Field(target, 0)));
break;
case 2:
ioprio = ioprio_get(IOPRIO_WHO_USER, Int_val(Field(target, 0)));
break;
default:
failwith("netsys_ioprio_get: internal error");
}
if (ioprio == -1)
uerror("ioprio_get", Nothing);
ioprio_class = ioprio >> IOPRIO_CLASS_SHIFT;
ioprio_data = ioprio & IOPRIO_PRIO_MASK;
switch (ioprio_class) {
case IOPRIO_CLASS_NONE:
result = Val_long(0);
break;
case IOPRIO_CLASS_RT:
result = caml_alloc(1, 0);
Store_field(result, 0, Val_int(ioprio_data));
break;
case IOPRIO_CLASS_BE:
result = caml_alloc(1, 1);
Store_field(result, 0, Val_int(ioprio_data));
break;
case IOPRIO_CLASS_IDLE:
result = Val_long(1);
break;
default:
failwith("netsys_ioprio_get: Unexpected result");
}
return result;
#else
/* not ioprio_supported: */
unix_error(ENOSYS, "ioprio_get", Nothing);
#endif
/* ioprio_supported */
}
value xdiff_diff( value old_data, value new_data, value ctxlen )
{
CAMLparam3 (old_data, new_data, ctxlen);
CAMLlocal1(dif_data);
mmfile_t mf1, mf2, mf3;
xdemitcb_t ecb;
xpparam_t xpp;
xdemitconf_t xecfg;
long dif_size;
if (xdlt_store_mmfile(String_val(old_data), string_length(old_data), &mf1) < 0) {
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
if (xdlt_store_mmfile(String_val(new_data), string_length(new_data), &mf2) < 0) {
xdl_free_mmfile(&mf1);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
if (xdl_init_mmfile(&mf3, XDLT_STD_BLKSIZE, XDL_MMF_ATOMIC) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
ecb.priv = &mf3;
ecb.outf = xdlt_outf;
xpp.flags = 0;
xecfg.ctxlen = Int_val(ctxlen);
if (xdl_diff(&mf1, &mf2, &xpp, &xecfg, &ecb) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
dif_size = xdlt_mmfile_size(&mf3);
dif_data = alloc_string(dif_size);
if (xdlt_read_mmfile(String_val(dif_data), &mf3) < 0) {
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
sprintf(ELINE, "%s:%d failed", __FILE__, __LINE__);
failwith(ELINE);
}
xdl_free_mmfile(&mf1);
xdl_free_mmfile(&mf2);
xdl_free_mmfile(&mf3);
CAMLreturn(dif_data);
}
void checkfbound(MYSQL_RES* dbres, int f, char* fcn)
{
if (dbres == NULL)
failwith("Mysql: non-select dbresult");
if (f < 0 || f >= (int)mysql_num_fields(dbres)) {
char buf[128];
sprintf(buf,
"Mysql.%s: illegal field number %d; must be in [0..%d]",
fcn, f, mysql_num_fields(dbres)-1);
failwith(buf);
}
}
/*
* Create the shell struct.
* We try to get a handle on the console,
* but don't stress if it doesn't exist.
*/
value omake_shell_sys_init(value v_unit)
{
CAMLparam1(v_unit);
Process *processp;
HANDLE c_stdin;
DWORD mode;
int status;
#ifdef OSH_DEBUG
fprintf(stderr, "omake_shell_sys_init\n");
fflush(stderr);
#endif
if (state)
/* Init was already called before */
CAMLreturn(Val_unit);
/* Allocate a struct for the current process */
processp = (Process *) malloc(sizeof(Process));
if(processp == 0)
failwith("Omake_shell_csys.create_state: out of memory");
memset(processp, 0, sizeof(Process));
/* Allocate the state */
state = (ShellState *) malloc(sizeof(ShellState));
if(state == 0)
failwith("Omake_shell_csys.create_state: out of memory");
memset(state, 0, sizeof(ShellState));
state->pid_counter = INIT_PID;
state->changed = CreateEvent(NULL, FALSE, FALSE, NULL);
state->current_pgrp = INIT_PID;
/* Initialize this process */
processp->pid = INIT_PID;
processp->pgrp = INIT_PID;
processp->status = STATUS_RUNNING;
processp->handle = GetCurrentProcess();
processp->wid = GetCurrentProcessId();
state->processes = processp;
/* Try to get the console */
c_stdin = GetStdHandle(STD_INPUT_HANDLE);
if(c_stdin == INVALID_HANDLE_VALUE)
CAMLreturn(Val_unit);
status = GetConsoleMode(c_stdin, &mode);
if(status)
state->console = c_stdin;
/* Install the console control handler */
SetConsoleCtrlHandler(console_ctrl_handler, TRUE);
CAMLreturn(Val_unit);
}
CAMLprim value get_full_path( value f ) {
#ifdef _WIN32
char path[MAX_PATH];
if( GetFullPathName(String_val(f),MAX_PATH,path,NULL) == 0 )
failwith("get_full_path");
return caml_copy_string(path);
#else
char path[4096];
if( realpath(String_val(f),path) == NULL )
failwith("get_full_path");
return caml_copy_string(path);
#endif
}
CAMLprim value netsys_zero_pages(value memv, value offsv, value lenv)
{
#if defined(HAVE_MMAP) && defined(HAVE_SYSCONF) && defined(MAP_ANON) && defined (MAP_FIXED)
struct caml_bigarray *mem = Bigarray_val(memv);
long offs = Long_val(offsv);
long len = Long_val(lenv);
long pgsize = sysconf(_SC_PAGESIZE);
char *data = ((char*) mem->data) + offs;
void *data2;
if (((uintnat) data) % pgsize == 0 && len % pgsize == 0) {
if (len > 0) {
data2 = mmap(data, len, PROT_READ|PROT_WRITE,
MAP_PRIVATE | MAP_ANON | MAP_FIXED,
(-1), 0);
if (data2 == (void *) -1) uerror("mmap", Nothing);
if (((void *) data) != data2)
failwith("Netsys_mem.zero_pages assertion failed");
}
}
else
invalid_argument("Netsys_mem.zero_pages only for whole pages");
return Val_unit;
#else
invalid_argument("Netsys_mem.zero_pages not available");
#endif
}
value dGifGetExtension( value hdl )
{
CAMLparam1(hdl);
CAMLlocal3(ext,exts,res);
CAMLlocal1(newres);
GifFileType *GifFile = (GifFileType*) hdl;
int func;
GifByteType *extData;
exts = Val_int(0);
if (DGifGetExtension(GifFile,&func, &extData) == GIF_ERROR){
failwith("DGifGetExtension");
}
while( extData != NULL ){
ext= alloc_string(extData[0]);
memcpy(String_val(ext), &extData[1], extData[0]);
newres = alloc_small(2,0);
caml_modify_field(newres, 0, ext);
caml_modify_field(newres, 1, exts);
exts= newres;
DGifGetExtensionNext(GifFile, &extData);
}
res = alloc_small(2,0);
caml_modify_field(res,0, Val_int(func));
caml_modify_field(res,1, exts);
CAMLreturn(res);
}
value dGifOpenFileName( value name )
{
CAMLparam1(name);
CAMLlocal1(res);
CAMLlocalN(r,2);
GifFileType *GifFile;
int i;
#if (GIFLIB_MAJOR <= 4)
GifFile = DGifOpenFileName( String_val(name) );
#else
GifFile = DGifOpenFileName( String_val(name), NULL);
#endif
if(GifFile == NULL){
failwith("DGifOpenFileName");
}
r[0] = Val_ScreenInfo( GifFile );
r[1] = (value) GifFile;
res = alloc_small(2,0);
for(i=0; i<2; i++) caml_modify_field(res, i, r[i]);
CAMLreturn(res);
}
static void serialize_nat(value nat,
uintnat * wsize_32,
uintnat * wsize_64)
{
mlsize_t len = Wosize_val(nat) - 1;
#ifdef ARCH_SIXTYFOUR
len = len * 2; /* two 32-bit words per 64-bit digit */
if (len >= ((mlsize_t)1 << 32))
failwith("output_value: nat too big");
#endif
serialize_int_4((int32) len);
#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
{ int32 * p;
mlsize_t i;
for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */
serialize_int_4(p[0]); /* high 32 bits of 64-bit digit */
}
}
#else
serialize_block_4(Data_custom_val(nat), len);
#endif
*wsize_32 = len * 4;
*wsize_64 = len * 4;
}
//+ external txn_begin : dbenv -> t option -> begin_flag list -> t
//+ = "caml_txn_begin"
value caml_txn_begin(value dbenv, value parent_opt, value vflags) {
CAMLparam3(dbenv,parent_opt,vflags);
CAMLlocal1(rval);
int err,flags;
DB_TXN *parent, *newtxn;
test_dbenv_closed(dbenv);
flags = convert_flag_list(vflags,txn_begin_flags);
if (Is_None(parent_opt)) { parent = NULL; }
else {
test_txn_closed(Some_val(parent_opt));
parent = UW_txn(Some_val(parent_opt));
//printf("********* parented transaction ***************\n"); fflush(stdout);
}
err = UW_dbenv(dbenv)->txn_begin(UW_dbenv(dbenv), parent, &newtxn, flags);
if (err != 0) {
if (err == ENOMEM) {
failwith("Maximum # of concurrent transactions reached");
} else {
UW_dbenv(dbenv)->err(UW_dbenv(dbenv), err,"caml_txn_begin");
}
}
rval = alloc_custom(&txn_custom,Camltxn_wosize,0,1);
UW_txn(rval) = newtxn;
UW_txn_closed(rval) = False;
CAMLreturn(rval);
}
CAMLprim value netsys_wait_not_event(value nev)
{
#ifdef HAVE_POLL
struct not_event *ne;
struct pollfd p;
int code, e;
CAMLparam1(nev);
ne = *(Not_event_val(nev));
if (ne->fd1 == -1)
failwith("Netsys_posix.wait_event: already destroyed");
caml_enter_blocking_section();
p.fd = ne->fd1;
p.events = POLLIN;
p.revents = 0;
code = poll(&p, 1, (-1));
e = errno;
caml_leave_blocking_section();
if (code == -1) unix_error(e, "poll", Nothing);
CAMLreturn(Val_unit);
#else
invalid_argument("Netsys_posix.wait_event not available");
#endif
}
static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefds, value exceptfds)
{
CAMLparam3(readfds, writefds, exceptfds);
CAMLlocal2(result, list);
int i;
switch( iterResult->EMode )
{
case SELECT_MODE_READ:
list = readfds;
break;
case SELECT_MODE_WRITE:
list = writefds;
break;
case SELECT_MODE_EXCEPT:
list = exceptfds;
break;
};
for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i )
{
list = Field(list, 1);
}
if (list == Val_unit)
failwith ("select.c: original file handle not found");
result = Field(list, 0);
CAMLreturn( result );
}
/* ML type : pgresult_ -> int */
EXTERNML value pq_cmdtuples(value pgresval)
{
const char* s = PQcmdTuples(PGresult_val(pgresval));
if (s == NULL)
failwith("pq_cmdtuples");
return Val_long(atoi(s));
}
/* ML type : pgconn_ -> string -> pgresult_ */
EXTERNML value pq_exec(value conn, value query)
{
PGresult* pgres = PQexec(PGconn_val(conn), String_val(query));
if (pgres == NULL)
failwith("pq_exec query failed");
return pgresult_alloc(pgres);
}
CAMLprim value sys_time() {
#ifdef _WIN32
#define EPOCH_DIFF (134774*24*60*60.0)
static LARGE_INTEGER freq;
static int freq_init = -1;
LARGE_INTEGER counter;
if( freq_init == -1 )
freq_init = QueryPerformanceFrequency(&freq);
if( !freq_init || !QueryPerformanceCounter(&counter) ) {
SYSTEMTIME t;
FILETIME ft;
ULARGE_INTEGER ui;
GetSystemTime(&t);
if( !SystemTimeToFileTime(&t,&ft) )
failwith("sys_cpu_time");
ui.LowPart = ft.dwLowDateTime;
ui.HighPart = ft.dwHighDateTime;
return caml_copy_double( ((double)ui.QuadPart) / 10000000.0 - EPOCH_DIFF );
}
return caml_copy_double( ((double)counter.QuadPart) / ((double)freq.QuadPart) );
#else
struct tms t;
times(&t);
return caml_copy_double( ((double)(t.tms_utime + t.tms_stime)) / CLK_TCK );
#endif
}
void cpgs_free(sint *handle)
{
if(*handle<0 || *handle>=cpgs_n || !cpgs_info[*handle])
failwith("invalid handle to cgps_free");
gs_data_free(cpgs_info[*handle]);
cpgs_info[*handle] = 0;
}
static HANDLE handle_of_descr(value x)
{
if(Descr_kind_val(x) != KIND_HANDLE){
failwith("mlterminal(the channel is not a file handle)");
}
return Handle_val(x);
}
