Posted to tcl by hypnotoad at Fri Jan 26 16:37:50 GMT 2018view raw

  1. noop {
  2. * Copyright (c) 2015,2017 Stuart Cassoff <stwo@users.sourceforge.net>
  3. *
  4. * Permission to use, copy, modify, and/or distribute this software for any
  5. * purpose with or without fee is hereby granted, provided that the above
  6. * copyright notice and this permission notice appear in all copies.
  7. *
  8. * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  9. * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  10. * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  11. * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  12. * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  13. * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  14. * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  15.  
  16. * tjpledge.c
  17. *
  18. * Tcl / Jim interface to pledge(3).
  19. *
  20.  
  21. * Notes:
  22. *
  23. }
  24. my include <unistd.h>
  25. my include <errno.h>
  26. # strerror
  27. my include <string.h>
  28.  
  29. my code header {
  30. #define COMBIEN(Z) ((int) (sizeof(Z) / sizeof(Z[0])))
  31. }
  32. set mode tcl
  33. if {[my <project> define cget FOR_JIM 0]} {
  34. set mode jim
  35. } elseif [my <project> define cget FOR_TCL_WENC 0] {
  36. set mode tcl_wenc
  37. }
  38.  
  39. switch $mode {
  40. jim {
  41. my include <jim-subcmd.h>
  42. my code header {
  43. # define EZT_OK JIM_OK
  44. # define EZT_ERROR JIM_ERR
  45. # define Ezt_Alloc Jim_Alloc
  46. # define Ezt_Free Jim_Free
  47. # define Ezt_PosixError() strerror(errno)
  48. # define Ezt_WrongNumArgs Jim_WrongNumArgs
  49. # define Ezt_IncrRefCount Jim_IncrRefCount
  50. # define Ezt_DecrRefCount(O) Jim_DecrRefCount(interp,(O))
  51. # define Ezt_SetResult(O) Jim_SetResult(interp,(O))
  52. # define Ezt_Obj Jim_Obj
  53. # define Ezt_Interp Jim_Interp
  54. # define Ezt_NewInt(I) Ezt_NewIntObj(interp,(I))
  55. # define Ezt_GetInt(I,P) Ezt_GetIntFromJimObj(interp,(I),(P))
  56. # define Ezt_NewWide(I) Jim_NewWideObj(interp,(I))
  57. # define Ezt_GetWide Jim_GetWide
  58. # define Ezt_NewString(S,L) Jim_NewStringObj(interp,(S),(L))
  59. # define Ezt_GetString Jim_GetString
  60. # define Ezt_GetBytes Jim_GetString
  61. # define Ezt_NewList() Jim_NewListObj(interp, NULL, 0)
  62. # define Ezt_ListAppend(L,O) Jim_ListAppendElement(interp,(L),(O))
  63. # define Ezt_NewDict() Jim_NewDictObj(interp, NULL, 0)
  64. # define Ezt_DictPut(D,KO,VO) Jim_DictAddElement(interp,(D),(KO),(VO))
  65. # define ezt_wide jim_wide
  66. # define EZT_SUBCMD(S) int (S) (Ezt_Interp *interp, int objc, Ezt_Obj *const *objv)
  67. # define EZT_CMD(S) int (S) (Ezt_Interp *interp, int objc, Ezt_Obj *const *objv)
  68. # define ezt_subcmd_type jim_subcmd_type
  69. }
  70. set EZT_SUBCMD {Ezt_Interp *interp, int objc, Ezt_Obj *const *objv}
  71. set EZT_CMD {Ezt_Interp *interp, int objc, Ezt_Obj *const *objv}
  72. } ; # JIM
  73. default {
  74. my include <tcl.h>
  75. my code header {
  76. # define EZT_OK TCL_OK
  77. # define EZT_ERROR TCL_ERROR
  78. # define Ezt_Alloc ckalloc
  79. # define Ezt_Free ckfree
  80. # define Ezt_PosixError() Tcl_PosixError(interp)
  81. # define Ezt_WrongNumArgs Tcl_WrongNumArgs
  82. # define Ezt_IncrRefCount Tcl_IncrRefCount
  83. # define Ezt_DecrRefCount(O) Tcl_DecrRefCount((O))
  84. # define Ezt_SetResult(O) Tcl_SetObjResult(interp,(O))
  85. # define Ezt_Obj Tcl_Obj
  86. # define Ezt_Interp Tcl_Interp
  87. # define Ezt_NewInt Tcl_NewIntObj
  88. # define Ezt_GetInt(I,P) Tcl_GetIntFromObj(interp,(I),(P))
  89. # define Ezt_NewWide Tcl_NewWideIntObj
  90. # define Ezt_GetWide Tcl_GetWideIntFromObj
  91. # define Ezt_NewString Tcl_NewStringObj
  92. # define Ezt_GetString Tcl_GetStringFromObj
  93. # define Ezt_GetBytes Tcl_GetByteArrayFromObj
  94. # define Ezt_NewList() Tcl_NewListObj(0,NULL)
  95. # define Ezt_ListAppend(L,O) Tcl_ListObjAppendElement(interp,(L),(O))
  96. # define Ezt_NewDict() Tcl_NewDictObj()
  97. # define Ezt_DictPut(D,KO,VO) Tcl_DictObjPut(interp,(D),(KO),(VO))
  98. # define ezt_wide TclWideInt
  99. # define EZT_SUBCMD(S) int (S) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
  100. # define EZT_CMD EZT_SUBCMD
  101. }
  102. set EZT_SUBCMD {ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]}
  103. set EZT_CMD $EZT_SUBCMD
  104. my cstructure ezt_subcmd_type {
  105. const char *name;
  106. const char *args;
  107. Tcl_ObjCmdProc *proc;
  108. short minargs;
  109. short maxargs;
  110. unsigned short flags;
  111. }
  112. } ; # default
  113. } ; #switch
  114.  
  115. noop {
  116. # Function not used
  117. if {$jim_mode} {
  118. my c_function {static Jim_Obj *Ezt_NewIntObj (Jim_Interp *interp, int i)} {
  119. return Jim_NewWideObj(interp, (ezt_wide) i);
  120. }
  121. my c_function {static int
  122. Ezt_GetIntFromJimObj (Jim_Interp *interp, Jim_Obj *objPtr, int *intPtr)} {
  123. jim_wide w;
  124. if (Jim_GetWide(interp, objPtr, &w) != JIM_OK) { return JIM_ERR; }
  125. *intPtr = (int) w;
  126. return JIM_OK;
  127. }
  128. }
  129.  
  130. set body {}
  131. if {$mode eq "tcl_wenc"} {
  132. set body {
  133. Tcl_DString req;
  134. int ret = EZT_OK;
  135.  
  136. if (objc < 2 || objc > 3) {
  137. Ezt_WrongNumArgs(interp, 1, objv, "promises ?paths?");
  138. return EZT_ERROR;
  139. }
  140.  
  141. Tcl_DStringInit(&req);
  142. Tcl_UtfToExternalDString(NULL, Ezt_GetString(objv[1], NULL), -1, &req);
  143.  
  144. if (objc == 2) {
  145. if (pledge(Tcl_DStringValue(&req), NULL) == -1) {
  146. Ezt_SetResult(Ezt_NewString(Tcl_PosixError(interp), -1));
  147. ret = EZT_ERROR;
  148. }
  149. } else if (objc == 3) {
  150. const char **paths = NULL;
  151. Tcl_DString *dsa;
  152. int lobjc;
  153. Ezt_Obj **lobjv;
  154. int i;
  155. if (Tcl_ListObjGetElements(interp, objv[2], &lobjc, &lobjv) != EZT_OK) {
  156. ret = EZT_ERROR;
  157. goto quitting;
  158. }
  159. dsa = ckalloc(lobjc * sizeof(*dsa));
  160. paths = ckalloc((lobjc + 1) * sizeof(*paths));
  161. for (i = 0; i < lobjc; i++) {
  162. Tcl_DStringInit(&dsa[i]);
  163. paths[i] = Tcl_UtfToExternalDString(NULL, Tcl_GetString(lobjv[i]), -1, &dsa[i]);
  164. }
  165. paths[i] = NULL;
  166. if (pledge(Tcl_DStringValue(&req), paths) == -1) {
  167. Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1));
  168. ret = EZT_ERROR;
  169. }
  170. for (i = 0; paths[i] != NULL; i++) {
  171. Tcl_DStringFree(&dsa[i]);
  172. }
  173. ckfree(dsa);
  174. ckfree(paths);
  175. }
  176.  
  177. quitting:;
  178.  
  179. Tcl_DStringFree(&req);
  180.  
  181. return ret;
  182. }
  183. # END TCL_WENC
  184. } else {
  185. set body {
  186. const char **paths = NULL;
  187. int ret = EZT_OK;
  188.  
  189. if (objc < 2 || objc > 3) {
  190. Ezt_WrongNumArgs(interp, 1, objv, "promises ?paths?");
  191. return EZT_ERROR;
  192. }
  193. }
  194. if {$mode eq "jim"} {
  195. ::practcl::cputs body {
  196. if (objc == 3) {
  197. int llen, i;
  198. Ezt_Obj *o;
  199.  
  200. llen = Jim_ListLength(interp, objv[2]);
  201. paths = (const char **) Ezt_Alloc((llen + 1) * sizeof(*paths));
  202. for (i = 0; i < llen; i++) {
  203. o = Jim_ListGetIndex(interp, objv[2], i);
  204. paths[i] = Ezt_GetString(o, NULL);
  205. }
  206. paths[i] = NULL;
  207. }
  208. }
  209. } else {
  210. ::practcl::cputs body {
  211. if (objc == 3) {
  212. int llen, i;
  213. Ezt_Obj **lobjv;
  214. if (Tcl_ListObjGetElements(interp, objv[2], &llen, &lobjv) != EZT_OK) {
  215. return EZT_ERROR;
  216. }
  217. paths = (const char **) Ezt_Alloc((llen + 1) * sizeof(*paths));
  218. for (i = 0; i < llen; i++) {
  219. o = lobjv[i];
  220. paths[i] = Ezt_GetString(o, NULL);
  221. }
  222. paths[i] = NULL;
  223. }
  224. }
  225. }
  226. ::practcl::cputs body {
  227. if (pledge(Ezt_GetString(objv[1], NULL), paths) == -1) {
  228. Ezt_SetResult(Ezt_NewString(Ezt_PosixError(), -1));
  229. ret = EZT_ERROR;
  230. }
  231.  
  232. Ezt_Free((char *) paths);
  233.  
  234. return ret;
  235. }
  236. }
  237.  
  238. if {$mode eq "jim"} {
  239. my code header {
  240. #define MIN_TCL_VERSION "8.5"
  241. #define TJPledge_NS "::pledge"
  242. #define TJPledge_CMD "pledge"
  243. }
  244. my c_function "static TJPledge_PledgeCmd\($EXT_CMD\)" $body
  245. my c_function {EXTERN int Jim_pledgeInit (Jim_Interp *interp)} {
  246. if (Jim_CreateCommand(interp, "pledge", TJPledge_PledgeCmd, NULL, NULL) != JIM_OK) { return JIM_ERR; }
  247. if (Jim_PackageProvide(interp, PACKAGE_NAME, PACKAGE_VERSION, JIM_ERRMSG) != JIM_OK) { return JIM_ERR; }
  248. return JIM_OK;
  249. }
  250. my c_function
  251. } else {
  252. my c_tclcmd "::pledge" $body
  253. }
  254.