Posted to tcl by hypnotoad at Fri Jan 26 16:37:50 GMT 2018view raw
- noop {
- * Copyright (c) 2015,2017 Stuart Cassoff <stwo@users.sourceforge.net>
- *
- * Permission to use, copy, modify, and/or distribute this software for any
- * purpose with or without fee is hereby granted, provided that the above
- * copyright notice and this permission notice appear in all copies.
- *
- * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
- * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
- * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
- * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
- * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
- * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
- * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
- * tjpledge.c
- *
- * Tcl / Jim interface to pledge(3).
- *
- * Notes:
- *
- }
- my include <unistd.h>
- my include <errno.h>
- # strerror
- my include <string.h>
- my code header {
- #define COMBIEN(Z) ((int) (sizeof(Z) / sizeof(Z[0])))
- }
- set mode tcl
- if {[my <project> define cget FOR_JIM 0]} {
- set mode jim
- } elseif [my <project> define cget FOR_TCL_WENC 0] {
- set mode tcl_wenc
- }
- switch $mode {
- jim {
- my include <jim-subcmd.h>
- my code header {
- # define EZT_OK JIM_OK
- # define EZT_ERROR JIM_ERR
- # define Ezt_Alloc Jim_Alloc
- # define Ezt_Free Jim_Free
- # define Ezt_PosixError() strerror(errno)
- # define Ezt_WrongNumArgs Jim_WrongNumArgs
- # define Ezt_IncrRefCount Jim_IncrRefCount
- # define Ezt_DecrRefCount(O) Jim_DecrRefCount(interp,(O))
- # define Ezt_SetResult(O) Jim_SetResult(interp,(O))
- # define Ezt_Obj Jim_Obj
- # define Ezt_Interp Jim_Interp
- # define Ezt_NewInt(I) Ezt_NewIntObj(interp,(I))
- # define Ezt_GetInt(I,P) Ezt_GetIntFromJimObj(interp,(I),(P))
- # define Ezt_NewWide(I) Jim_NewWideObj(interp,(I))
- # define Ezt_GetWide Jim_GetWide
- # define Ezt_NewString(S,L) Jim_NewStringObj(interp,(S),(L))
- # define Ezt_GetString Jim_GetString
- # define Ezt_GetBytes Jim_GetString
- # define Ezt_NewList() Jim_NewListObj(interp, NULL, 0)
- # define Ezt_ListAppend(L,O) Jim_ListAppendElement(interp,(L),(O))
- # define Ezt_NewDict() Jim_NewDictObj(interp, NULL, 0)
- # define Ezt_DictPut(D,KO,VO) Jim_DictAddElement(interp,(D),(KO),(VO))
- # define ezt_wide jim_wide
- # define EZT_SUBCMD(S) int (S) (Ezt_Interp *interp, int objc, Ezt_Obj *const *objv)
- # define EZT_CMD(S) int (S) (Ezt_Interp *interp, int objc, Ezt_Obj *const *objv)
- # define ezt_subcmd_type jim_subcmd_type
- }
- set EZT_SUBCMD {Ezt_Interp *interp, int objc, Ezt_Obj *const *objv}
- set EZT_CMD {Ezt_Interp *interp, int objc, Ezt_Obj *const *objv}
- } ; # JIM
- default {
- my include <tcl.h>
- my code header {
- # define EZT_OK TCL_OK
- # define EZT_ERROR TCL_ERROR
- # define Ezt_Alloc ckalloc
- # define Ezt_Free ckfree
- # define Ezt_PosixError() Tcl_PosixError(interp)
- # define Ezt_WrongNumArgs Tcl_WrongNumArgs
- # define Ezt_IncrRefCount Tcl_IncrRefCount
- # define Ezt_DecrRefCount(O) Tcl_DecrRefCount((O))
- # define Ezt_SetResult(O) Tcl_SetObjResult(interp,(O))
- # define Ezt_Obj Tcl_Obj
- # define Ezt_Interp Tcl_Interp
- # define Ezt_NewInt Tcl_NewIntObj
- # define Ezt_GetInt(I,P) Tcl_GetIntFromObj(interp,(I),(P))
- # define Ezt_NewWide Tcl_NewWideIntObj
- # define Ezt_GetWide Tcl_GetWideIntFromObj
- # define Ezt_NewString Tcl_NewStringObj
- # define Ezt_GetString Tcl_GetStringFromObj
- # define Ezt_GetBytes Tcl_GetByteArrayFromObj
- # define Ezt_NewList() Tcl_NewListObj(0,NULL)
- # define Ezt_ListAppend(L,O) Tcl_ListObjAppendElement(interp,(L),(O))
- # define Ezt_NewDict() Tcl_NewDictObj()
- # define Ezt_DictPut(D,KO,VO) Tcl_DictObjPut(interp,(D),(KO),(VO))
- # define ezt_wide TclWideInt
- # define EZT_SUBCMD(S) int (S) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
- # define EZT_CMD EZT_SUBCMD
- }
- set EZT_SUBCMD {ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]}
- set EZT_CMD $EZT_SUBCMD
- my cstructure ezt_subcmd_type {
- const char *name;
- const char *args;
- Tcl_ObjCmdProc *proc;
- short minargs;
- short maxargs;
- unsigned short flags;
- }
- } ; # default
- } ; #switch
- noop {
- # Function not used
- if {$jim_mode} {
- my c_function {static Jim_Obj *Ezt_NewIntObj (Jim_Interp *interp, int i)} {
- return Jim_NewWideObj(interp, (ezt_wide) i);
- }
- my c_function {static int
- Ezt_GetIntFromJimObj (Jim_Interp *interp, Jim_Obj *objPtr, int *intPtr)} {
- jim_wide w;
- if (Jim_GetWide(interp, objPtr, &w) != JIM_OK) { return JIM_ERR; }
- *intPtr = (int) w;
- return JIM_OK;
- }
- }
- set body {}
- if {$mode eq "tcl_wenc"} {
- set body {
- Tcl_DString req;
- int ret = EZT_OK;
- if (objc < 2 || objc > 3) {
- Ezt_WrongNumArgs(interp, 1, objv, "promises ?paths?");
- return EZT_ERROR;
- }
- Tcl_DStringInit(&req);
- Tcl_UtfToExternalDString(NULL, Ezt_GetString(objv[1], NULL), -1, &req);
- if (objc == 2) {
- if (pledge(Tcl_DStringValue(&req), NULL) == -1) {
- Ezt_SetResult(Ezt_NewString(Tcl_PosixError(interp), -1));
- ret = EZT_ERROR;
- }
- } else if (objc == 3) {
- const char **paths = NULL;
- Tcl_DString *dsa;
- int lobjc;
- Ezt_Obj **lobjv;
- int i;
- if (Tcl_ListObjGetElements(interp, objv[2], &lobjc, &lobjv) != EZT_OK) {
- ret = EZT_ERROR;
- goto quitting;
- }
- dsa = ckalloc(lobjc * sizeof(*dsa));
- paths = ckalloc((lobjc + 1) * sizeof(*paths));
- for (i = 0; i < lobjc; i++) {
- Tcl_DStringInit(&dsa[i]);
- paths[i] = Tcl_UtfToExternalDString(NULL, Tcl_GetString(lobjv[i]), -1, &dsa[i]);
- }
- paths[i] = NULL;
- if (pledge(Tcl_DStringValue(&req), paths) == -1) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1));
- ret = EZT_ERROR;
- }
- for (i = 0; paths[i] != NULL; i++) {
- Tcl_DStringFree(&dsa[i]);
- }
- ckfree(dsa);
- ckfree(paths);
- }
- quitting:;
- Tcl_DStringFree(&req);
- return ret;
- }
- # END TCL_WENC
- } else {
- set body {
- const char **paths = NULL;
- int ret = EZT_OK;
- if (objc < 2 || objc > 3) {
- Ezt_WrongNumArgs(interp, 1, objv, "promises ?paths?");
- return EZT_ERROR;
- }
- }
- if {$mode eq "jim"} {
- ::practcl::cputs body {
- if (objc == 3) {
- int llen, i;
- Ezt_Obj *o;
- llen = Jim_ListLength(interp, objv[2]);
- paths = (const char **) Ezt_Alloc((llen + 1) * sizeof(*paths));
- for (i = 0; i < llen; i++) {
- o = Jim_ListGetIndex(interp, objv[2], i);
- paths[i] = Ezt_GetString(o, NULL);
- }
- paths[i] = NULL;
- }
- }
- } else {
- ::practcl::cputs body {
- if (objc == 3) {
- int llen, i;
- Ezt_Obj **lobjv;
- if (Tcl_ListObjGetElements(interp, objv[2], &llen, &lobjv) != EZT_OK) {
- return EZT_ERROR;
- }
- paths = (const char **) Ezt_Alloc((llen + 1) * sizeof(*paths));
- for (i = 0; i < llen; i++) {
- o = lobjv[i];
- paths[i] = Ezt_GetString(o, NULL);
- }
- paths[i] = NULL;
- }
- }
- }
- ::practcl::cputs body {
- if (pledge(Ezt_GetString(objv[1], NULL), paths) == -1) {
- Ezt_SetResult(Ezt_NewString(Ezt_PosixError(), -1));
- ret = EZT_ERROR;
- }
- Ezt_Free((char *) paths);
- return ret;
- }
- }
- if {$mode eq "jim"} {
- my code header {
- #define MIN_TCL_VERSION "8.5"
- #define TJPledge_NS "::pledge"
- #define TJPledge_CMD "pledge"
- }
- my c_function "static TJPledge_PledgeCmd\($EXT_CMD\)" $body
- my c_function {EXTERN int Jim_pledgeInit (Jim_Interp *interp)} {
- if (Jim_CreateCommand(interp, "pledge", TJPledge_PledgeCmd, NULL, NULL) != JIM_OK) { return JIM_ERR; }
- if (Jim_PackageProvide(interp, PACKAGE_NAME, PACKAGE_VERSION, JIM_ERRMSG) != JIM_OK) { return JIM_ERR; }
- return JIM_OK;
- }
- my c_function
- } else {
- my c_tclcmd "::pledge" $body
- }