1/* Chantest.c - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> 2 * 3 * Sample extention to check that the stubs library is working correctly. 4 * This also serves to illustrate the use of the stubs library. 5 * 6 * $Id: chantest.c,v 1.1 2004/11/09 23:11:00 patthoyts Exp $ 7 */ 8 9#include <memchan.h> 10 11#undef TCL_STORAGE_CLASS 12#define TCL_STORAGE_CLASS DLLEXPORT 13 14int TestObjCmd(ClientData clientData, Tcl_Interp *interp, 15 int objc, Tcl_Obj *const objv[]); 16 17 18EXTERN int 19Chantest_Init(Tcl_Interp *interp) 20{ 21 int r = TCL_OK; 22 const char *tcl = NULL; 23 const char *memchan = NULL; 24 25#ifdef USE_TCL_STUBS 26 tcl = Tcl_InitStubs(interp, "8.4", 0); 27#endif 28 29#ifdef USE_MEMCHAN_STUBS 30 memchan = Memchan_InitStubs(interp, "2.2", 0); 31#endif 32 33 if (tcl == NULL || memchan == NULL) { 34 Tcl_SetResult(interp, "error loading memchan via stubs", TCL_STATIC); 35 r = TCL_ERROR; 36 } else { 37 Tcl_CreateObjCommand(interp, "chantest", TestObjCmd, 38 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 39 r = Tcl_PkgProvide(interp, "Chantest", "0.1"); 40 } 41 return r; 42} 43 44int 45TestObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) 46{ 47 Tcl_Channel chan = NULL, chan2 = NULL; 48 Tcl_Obj *resObj = NULL; 49 char *type = ""; 50 int r = TCL_OK; 51 52 if (objc != 2) { 53 Tcl_WrongNumArgs(interp, 1, objv, "type"); 54 return TCL_ERROR; 55 } 56 57 type = Tcl_GetString(objv[1]); 58 if (strcmp("memchan", type) == 0) { 59 chan = Memchan_CreateMemoryChannel(interp, 0); 60 } else if (strcmp("fifo", type) == 0) { 61 chan = Memchan_CreateFifoChannel(interp); 62 } else if (strcmp("fifo2", type) == 0) { 63 Memchan_CreateFifo2Channel(interp, &chan, &chan2); 64 } else if (strcmp("null", type) == 0) { 65 chan = Memchan_CreateNullChannel(interp); 66 } else if (strcmp("zero", type) == 0) { 67 chan = Memchan_CreateZeroChannel(interp); 68 } else if (strcmp("random", type) == 0) { 69 chan = Memchan_CreateRandomChannel(interp); 70 } 71 72 if (chan2 != NULL) { 73 Tcl_Obj *name[2]; 74 name[0] = Tcl_NewStringObj(Tcl_GetChannelName(chan), -1); 75 name[1] = Tcl_NewStringObj(Tcl_GetChannelName(chan2), -1); 76 resObj = Tcl_NewListObj(2, name); 77 r = TCL_OK; 78 } else if (chan != NULL) { 79 resObj = Tcl_NewStringObj(Tcl_GetChannelName(chan), -1); 80 r = TCL_OK; 81 } else { 82 resObj = Tcl_NewStringObj("error", -1); 83 r = TCL_ERROR; 84 } 85 86 Tcl_SetObjResult(interp, resObj); 87 return r; 88} 89