value alloc_sockaddr(union sock_addr_union * adr /*in*/, socklen_param_type adr_len, int close_on_error) { value res; switch(adr->s_gen.sa_family) { #ifndef _WIN32 case AF_UNIX: { char * path; value n; /* PR#7039: harden against unnamed sockets */ if (adr_len > (char *)&(adr->s_unix.sun_path) - (char *)&(adr->s_unix)) path = adr->s_unix.sun_path; else path = ""; n = copy_string(path); Begin_root (n); res = alloc_small(1, 0); Field(res,0) = n; End_roots(); break; } #endif case AF_INET: { value a = alloc_inet_addr(&adr->s_inet.sin_addr); Begin_root (a); res = alloc_small(2, 1); Field(res,0) = a; Field(res,1) = Val_int(ntohs(adr->s_inet.sin_port)); End_roots(); break; } #ifdef HAS_IPV6 case AF_INET6: { value a = alloc_inet6_addr(&adr->s_inet6.sin6_addr); Begin_root (a); res = alloc_small(2, 1); Field(res,0) = a; Field(res,1) = Val_int(ntohs(adr->s_inet6.sin6_port)); End_roots(); break; } #endif default: if (close_on_error != -1) close (close_on_error); unix_error(EAFNOSUPPORT, "", Nothing); } return res; }
value mypushroot(value v, value fun, value arg) { Begin_root(v) callback(fun, arg); End_roots(); return v; }
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); }
CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) { long ofs, len, written; int numbytes, ret; char iobuf[UNIX_BUFFER_SIZE]; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; while (len > 0) { numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); enter_blocking_section(); ret = write(Int_val(fd), iobuf, numbytes); leave_blocking_section(); if (ret == -1) { if ((errno == EAGAIN || errno == EWOULDBLOCK) && written > 0) break; uerror("write", Nothing); } written += ret; ofs += ret; len -= ret; } End_roots(); return Val_long(written); }
CAMLprim value lwt_unix_read(value fd, value buf, value vofs, value vlen) { intnat ofs, len, written; DWORD numbytes, numwritten; DWORD err = 0; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); written = 0; if (len > 0) { numbytes = len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); ret = recv(s, &Byte(buf, ofs), numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); numwritten = ret; } else { HANDLE h = Handle_val(fd); if (! ReadFile(h, &Byte(buf, ofs), numbytes, &numwritten, NULL)) err = GetLastError(); } if (err) { win32_maperr(err); uerror("write", Nothing); } written = numwritten; } End_roots(); return Val_long(written); }
CAMLprim value unix_read(value fd, value buf, value ofs, value vlen) { intnat len; DWORD numbytes, numread; char iobuf[UNIX_BUFFER_SIZE]; DWORD err = 0; Begin_root (buf); len = Long_val(vlen); numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); enter_blocking_section(); ret = recv(s, iobuf, numbytes, 0); if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); numread = ret; } else { HANDLE h = Handle_val(fd); enter_blocking_section(); if (! ReadFile(h, iobuf, numbytes, &numread, NULL)) err = GetLastError(); leave_blocking_section(); } if (err) { win32_maperr(err); uerror("read", Nothing); } memmove (&Byte(buf, Long_val(ofs)), iobuf, numread); End_roots(); return Val_int(numread); }
CAMLprim value caml_thread_initialize(value unit) { value vthread = Val_unit; value descr; HANDLE tick_thread; DWORD th_id; /* Protect against repeated initialization (PR#1325) */ if (curr_thread != NULL) return Val_unit; Begin_root (vthread); /* Initialize the main mutex and acquire it */ caml_mutex = CreateMutex(NULL, TRUE, NULL); if (caml_mutex == NULL) caml_wthread_error("Thread.init"); /* Initialize the TLS keys */ thread_descriptor_key = TlsAlloc(); last_channel_locked_key = TlsAlloc(); /* Create a finalized value to hold thread handle */ vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value), caml_thread_finalize, 1, 1000); ((struct caml_thread_handle *)vthread)->handle = NULL; /* Create a descriptor for the current thread */ descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value)); Ident(descr) = Val_long(thread_next_ident); Start_closure(descr) = Val_unit; Threadhandle(descr) = (struct caml_thread_handle *) vthread; thread_next_ident++; /* Create an info block for the current thread */ curr_thread = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct)); DuplicateHandle(GetCurrentProcess(), GetCurrentThread(), GetCurrentProcess(), &(curr_thread->wthread), 0, FALSE, DUPLICATE_SAME_ACCESS); if (curr_thread->wthread == NULL) caml_wthread_error("Thread.init"); ((struct caml_thread_handle *)vthread)->handle = curr_thread->wthread; curr_thread->descr = descr; curr_thread->next = curr_thread; curr_thread->prev = curr_thread; /* The stack-related fields will be filled in at the next enter_blocking_section */ /* Associate the thread descriptor with the thread */ TlsSetValue(thread_descriptor_key, (void *) curr_thread); /* Set up the hooks */ prev_scan_roots_hook = scan_roots_hook; scan_roots_hook = caml_thread_scan_roots; enter_blocking_section_hook = caml_thread_enter_blocking_section; leave_blocking_section_hook = caml_thread_leave_blocking_section; try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section; caml_channel_mutex_free = caml_io_mutex_free; caml_channel_mutex_lock = caml_io_mutex_lock; caml_channel_mutex_unlock = caml_io_mutex_unlock; caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn; /* Fork the tick thread */ tick_thread = CreateThread(NULL, 0, caml_thread_tick, NULL, 0, &th_id); if (tick_thread == NULL) caml_wthread_error("Thread.init"); CloseHandle(tick_thread); End_roots(); return Val_unit; }
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(Socket_val(socket), level, option, (void *) &optval, &optsize) == -1) uerror(name, Nothing); switch (ty) { case TYPE_BOOL: 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 */ 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 */ Field(res, 0) = err; End_roots(); return res; } default: unix_error(EINVAL, name, Nothing); return Val_unit; /* Avoid warning */ } }
value my_alloc_sockaddr(struct sockaddr_storage *ss) { value res, a; struct sockaddr_un *sun; struct sockaddr_in *sin; struct sockaddr_in6 *sin6; switch(ss->ss_family) { case AF_UNIX: sun = (struct sockaddr_un *) ss; a = caml_copy_string(sun->sun_path); Begin_root (a); res = caml_alloc_small(1, 0); Field(res,0) = a; End_roots(); break; case AF_INET: sin = (struct sockaddr_in *) ss; a = caml_alloc_string(4); memcpy(String_val(a), &sin->sin_addr, 4); Begin_root (a); res = caml_alloc_small(2, 1); Field(res, 0) = a; Field(res, 1) = Val_int(ntohs(sin->sin_port)); End_roots(); break; case AF_INET6: sin6 = (struct sockaddr_in6 *) ss; a = caml_alloc_string(16); memcpy(String_val(a), &sin6->sin6_addr, 16); Begin_root (a); res = caml_alloc_small(2, 1); Field(res, 0) = a; Field(res, 1) = Val_int(ntohs(sin6->sin6_port)); End_roots(); break; default: unix_error(EAFNOSUPPORT, "", Nothing); } return res; }
value makeblock1(value tag, value accu) { value res; Begin_root(accu); res = alloc(1, Int_val(tag)); End_roots(); initialize(&Field(res,0), accu); return res; }
CAMLprim value caml_mutex_unlock(value mut) { BOOL retcode; Begin_root(mut) /* prevent deallocation of mutex */ enter_blocking_section(); retcode = ReleaseMutex(Mutex_val(mut)); leave_blocking_section(); End_roots(); if (!retcode) caml_wthread_error("Mutex.unlock"); return Val_unit; }
CAMLprim value caml_mutex_lock(value mut) { int retcode; Begin_root(mut) /* prevent deallocation of mutex */ enter_blocking_section(); retcode = WaitForSingleObject(Mutex_val(mut), INFINITE); leave_blocking_section(); End_roots(); if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock"); return Val_unit; }
CAMLprim value caml_thread_join(value th) { HANDLE h; Begin_root(th) /* prevent deallocation of handle */ h = Threadhandle(th)->handle; enter_blocking_section(); WaitForSingleObject(h, INFINITE); leave_blocking_section(); End_roots(); return Val_unit; }
static value alloc_process_status(HANDLE pid, int status) { value res, st; st = alloc(1, 0); Field(st, 0) = Val_int(status); Begin_root (st); res = alloc_small(2, 0); Field(res, 0) = Val_long((intnat) pid); Field(res, 1) = st; End_roots(); return res; }
CAMLprim value caml_mutex_lock(value mut) { int retcode; /* PR#4351: first try to acquire mutex without releasing the master lock */ retcode = WaitForSingleObject(Mutex_val(mut), 0); if (retcode == WAIT_OBJECT_0) return Val_unit; Begin_root(mut) /* prevent deallocation of mutex */ enter_blocking_section(); retcode = WaitForSingleObject(Mutex_val(mut), INFINITE); leave_blocking_section(); End_roots(); if (retcode == WAIT_FAILED) caml_wthread_error("Mutex.lock"); return Val_unit; }
CAMLprim value caml_condition_signal(value cond) { HANDLE s = Condition_val(cond)->sem; if (Condition_val(cond)->count > 0) { Condition_val(cond)->count --; Begin_root(cond) /* prevent deallocation of cond */ enter_blocking_section(); /* Increment semaphore by 1, waking up one waiter */ ReleaseSemaphore(s, 1, NULL); leave_blocking_section(); End_roots(); } return Val_unit; }
CAMLprim value caml_condition_broadcast(value cond) { HANDLE s = Condition_val(cond)->sem; uintnat c = Condition_val(cond)->count; if (c > 0) { Condition_val(cond)->count = 0; Begin_root(cond) /* prevent deallocation of cond */ enter_blocking_section(); /* Increment semaphore by c, waking up all waiters */ ReleaseSemaphore(s, c, NULL); leave_blocking_section(); End_roots(); } return Val_unit; }
CAMLprim value caml_mutex_lock(value wrapper) /* ML */ { st_mutex mut = Mutex_val(wrapper); st_retcode retcode; /* PR#4351: first try to acquire mutex without releasing the master lock */ if (st_mutex_trylock(mut) == PREVIOUSLY_UNLOCKED) return Val_unit; /* If unsuccessful, block on mutex */ Begin_root(wrapper) /* prevent the deallocation of mutex */ enter_blocking_section(); retcode = st_mutex_lock(mut); leave_blocking_section(); End_roots(); st_check_error(retcode, "Mutex.lock"); return Val_unit; }
CAMLprim value unix_read(value fd, value buf, value ofs, value len) { long numbytes; int ret; char iobuf[UNIX_BUFFER_SIZE]; Begin_root (buf); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); ret = read(Int_val(fd), iobuf, (int) numbytes); leave_blocking_section(); if (ret == -1) uerror("read", Nothing); memmove (&Byte(buf, Long_val(ofs)), iobuf, ret); End_roots(); return Val_int(ret); }
CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) { int ret, cv_flags; long numbytes; char iobuf[UNIX_BUFFER_SIZE]; cv_flags = convert_flag_list(flags, msg_flag_table); Begin_root (buff); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); ret = recv(Int_val(sock), iobuf, (int) numbytes, cv_flags); leave_blocking_section(); if (ret == -1) uerror("recv", Nothing); memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); End_roots(); return Val_int(ret); }
CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) { long ofs, len; int numbytes, ret; char iobuf[UNIX_BUFFER_SIZE]; Begin_root (buf); ofs = Long_val(vofs); len = Long_val(vlen); ret = 0; if (len > 0) { numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; memmove (iobuf, &Byte(buf, ofs), numbytes); enter_blocking_section(); ret = write(Int_val(fd), iobuf, numbytes); leave_blocking_section(); if (ret == -1) uerror("single_write", Nothing); } End_roots(); return Val_int(ret); }
CAMLprim value unix_accept(value sock) { int retcode; value res; value a; union sock_addr_union addr; socklen_param_type addr_len; addr_len = sizeof(addr); enter_blocking_section(); retcode = accept(Int_val(sock), &addr.s_gen, &addr_len); leave_blocking_section(); if (retcode == -1) uerror("accept", Nothing); a = alloc_sockaddr(&addr, addr_len, retcode); Begin_root (a); res = alloc_small(2, 0); Field(res, 0) = Val_int(retcode); Field(res, 1) = a; End_roots(); return res; }
CAMLprim value unix_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; while (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("write", Nothing); } written += numwritten; ofs += numwritten; len -= numwritten; } End_roots(); return Val_long(written); }
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; }
/* 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; }
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; }