Posted to tcl by sebres at Mon Jan 21 15:18:14 GMT 2019view raw

  1. /*
  2. * chanhandle.c --
  3. *
  4. * Test module to get native handle of channel.
  5. *
  6. * Compile:
  7. * mingw: gcc -O2 -DUSE_TCL_STUBS=1 -I$tcl/win -I$tcl/generic chanhandle.c -shared -o chanhandle.dll libtclstub87.a
  8. * *nix: gcc -O2 -DUSE_TCL_STUBS=1 -I$tcl/unix -I$tcl/generic chanhandle.c -shared -o chanhandle.so libtclstub87.a
  9. *
  10. * Usage:
  11. * $ tclsh87
  12. * % load chanhandle
  13. * % chan-handle r stdin
  14. * % chan-handle w stdout
  15. * % chan-handle r [set s [socket 127.0.0.1 80]]
  16. * % chan-handle w $s
  17. */
  18.  
  19. #include "tcl.h"
  20.  
  21. int GetChanHandleObjCmd(
  22. ClientData dummy,
  23. Tcl_Interp* interp,
  24. int objc,
  25. Tcl_Obj * const objv[]
  26. ) {
  27. Tcl_Channel chan;
  28. ClientData handle;
  29.  
  30. if (objc != 3) {
  31. Tcl_WrongNumArgs(interp, 1, objv, "r|w channel");
  32. return TCL_ERROR;
  33. }
  34.  
  35. chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL);
  36. if (!chan) {
  37. return TCL_ERROR;
  38. }
  39.  
  40. handle = 0;
  41. if (Tcl_GetChannelHandle(chan,
  42. (*Tcl_GetString(objv[1]) == 'r' ? TCL_READABLE : TCL_WRITABLE),
  43. &handle) != TCL_OK) {
  44. // Tcl_ResetResult(interp);
  45. return TCL_OK;
  46. };
  47.  
  48. Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)((intptr_t)handle)));
  49. return TCL_OK;
  50. }
  51.  
  52. int Chanhandle_Init(Tcl_Interp *interp) {
  53. if (!Tcl_InitStubs(interp, "8.5", 0)) {
  54. return TCL_ERROR;
  55. }
  56. Tcl_CreateObjCommand(interp, "chan-handle", GetChanHandleObjCmd, NULL, NULL);
  57. return TCL_OK;
  58. }
  59.  
  60.