コード例 #1
0
ファイル: socketaddr.c プロジェクト: ocsigen/ocaml-eliom
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;
}
コード例 #2
0
ファイル: callbackprim.c プロジェクト: ocsigen/ocaml-eliom
value mypushroot(value v, value fun, value arg)
{
  Begin_root(v)
    callback(fun, arg);
  End_roots();
  return v;
}
コード例 #3
0
ファイル: sendrecv.c プロジェクト: ocsigen/ocaml-eliom
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);
}
コード例 #4
0
ファイル: write.c プロジェクト: BrianMulhall/ocaml
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);
}
コード例 #5
0
ファイル: lwt_unix_windows.c プロジェクト: avsm/lwt-OLD
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);
}
コード例 #6
0
ファイル: read.c プロジェクト: MassD/ocaml
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);
}
コード例 #7
0
ファイル: win32.c プロジェクト: OpenXT/ocaml
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;
}
コード例 #8
0
ファイル: sockopt.c プロジェクト: avsm/ocaml-ppa
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 */
  }
}
コード例 #9
0
ファイル: sendmsg.c プロジェクト: haesbaert/extunix
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;
}
コード例 #10
0
ファイル: getglobal.c プロジェクト: aryx/fork-efuns-old
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;
}
コード例 #11
0
ファイル: win32.c プロジェクト: avsm/ocaml-community
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;
}
コード例 #12
0
ファイル: win32.c プロジェクト: avsm/ocaml-community
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;
}
コード例 #13
0
ファイル: win32.c プロジェクト: OpenXT/ocaml
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;
}
コード例 #14
0
ファイル: onlyWin32_c.c プロジェクト: lefessan/typerex-build
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;
}
コード例 #15
0
ファイル: win32.c プロジェクト: OpenXT/ocaml
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;
}
コード例 #16
0
ファイル: win32.c プロジェクト: avsm/ocaml-community
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;
}
コード例 #17
0
ファイル: win32.c プロジェクト: avsm/ocaml-community
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;
}
コード例 #18
0
ファイル: st_stubs.c プロジェクト: avsm/ocaml-ppa
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;
}
コード例 #19
0
ファイル: read.c プロジェクト: bmeurer/ocaml-arm
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);
}
コード例 #20
0
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);
}
コード例 #21
0
ファイル: write.c プロジェクト: BrianMulhall/ocaml
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);
}
コード例 #22
0
ファイル: accept.c プロジェクト: OpenXT/ocaml
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;
}
コード例 #23
0
ファイル: write.c プロジェクト: ocsigen/ocaml-eliom
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);
}
コード例 #24
0
ファイル: wait.c プロジェクト: OCamlPro/OCamlPro-OCaml-Branch
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;
}
コード例 #25
0
ファイル: cltkMain.c プロジェクト: OCamlPro/ocamltk
/* 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;
}
コード例 #26
0
ファイル: mlresolv_stub.c プロジェクト: ermine/mlresolv
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;
}