1/* 2 * threadSvKeylist.c -- 3 * 4 * This file implements keyed-list commands as part of the thread 5 * shared variable implementation. 6 * 7 * Keyed list implementation is borrowed from Mark Diekhans and 8 * Karl Lehenbauer "TclX" (extended Tcl) extension. Please look 9 * into the keylist.c file for more information. 10 * 11 * See the file "license.txt" for information on usage and redistribution 12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * Rcsid: @(#)$Id: threadSvKeylistCmd.c,v 1.3 2009/07/22 11:25:34 nijtmans Exp $ 15 * --------------------------------------------------------------------------- 16 */ 17 18#include "threadSvCmd.h" 19#include "tclXkeylist.h" 20 21/* 22 * This is defined in keylist.c. We need it here 23 * to be able to plug-in our custom keyed-list 24 * object duplicator which produces proper deep 25 * copies of the keyed-list objects. The standard 26 * one produces shallow copies which are not good 27 * for usage in the thread shared variables code. 28 */ 29 30extern Tcl_ObjType keyedListType; 31 32/* 33 * Wrapped keyed-list commands 34 */ 35 36static Tcl_ObjCmdProc SvKeylsetObjCmd; 37static Tcl_ObjCmdProc SvKeylgetObjCmd; 38static Tcl_ObjCmdProc SvKeyldelObjCmd; 39static Tcl_ObjCmdProc SvKeylkeysObjCmd; 40 41/* 42 * This mutex protects a static variable which tracks 43 * registration of commands and object types. 44 */ 45 46static Tcl_Mutex initMutex; 47 48 49/* 50 *----------------------------------------------------------------------------- 51 * 52 * Sv_RegisterKeylistCommands -- 53 * 54 * Register shared variable commands for TclX keyed lists. 55 * 56 * Results: 57 * A standard Tcl result. 58 * 59 * Side effects: 60 * Memory gets allocated 61 * 62 *----------------------------------------------------------------------------- 63 */ 64void 65Sv_RegisterKeylistCommands(void) 66{ 67 static int initialized; 68 69 if (initialized == 0) { 70 Tcl_MutexLock(&initMutex); 71 if (initialized == 0) { 72 Sv_RegisterCommand("keylset", SvKeylsetObjCmd, NULL, NULL); 73 Sv_RegisterCommand("keylget", SvKeylgetObjCmd, NULL, NULL); 74 Sv_RegisterCommand("keyldel", SvKeyldelObjCmd, NULL, NULL); 75 Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, NULL); 76 Sv_RegisterObjType(&keyedListType, DupKeyedListInternalRepShared); 77 initialized = 1; 78 } 79 Tcl_MutexUnlock(&initMutex); 80 } 81} 82 83/* 84 *----------------------------------------------------------------------------- 85 * 86 * SvKeylsetObjCmd -- 87 * 88 * This procedure is invoked to process the "tsv::keylset" command. 89 * See the user documentation for details on what it does. 90 * 91 * Results: 92 * A standard Tcl result. 93 * 94 * Side effects: 95 * See the user documentation. 96 * 97 *----------------------------------------------------------------------------- 98 */ 99 100static int 101SvKeylsetObjCmd(arg, interp, objc, objv) 102 ClientData arg; /* Not used. */ 103 Tcl_Interp *interp; /* Current interpreter. */ 104 int objc; /* Number of arguments. */ 105 Tcl_Obj *const objv[]; /* Argument objects. */ 106{ 107 int i, off, ret, flg; 108 char *key; 109 Tcl_Obj *val; 110 Container *svObj = (Container*)arg; 111 112 /* 113 * Syntax: 114 * sv::keylset array lkey key value ?key value ...? 115 * $keylist keylset key value ?key value ...? 116 */ 117 118 flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; 119 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); 120 if (ret != TCL_OK) { 121 return TCL_ERROR; 122 } 123 if ((objc - off) < 2 || ((objc - off) % 2)) { 124 Tcl_WrongNumArgs(interp, off, objv, "key value ?key value ...?"); 125 goto cmd_err; 126 } 127 for (i = off; i < objc; i += 2) { 128 key = Tcl_GetString(objv[i]); 129 val = Sv_DuplicateObj(objv[i+1]); 130 ret = TclX_KeyedListSet(interp, svObj->tclObj, key, val); 131 if (ret != TCL_OK) { 132 goto cmd_err; 133 } 134 } 135 136 return Sv_PutContainer(interp, svObj, SV_CHANGED); 137 138 cmd_err: 139 return Sv_PutContainer(interp, svObj, SV_ERROR); 140} 141 142/* 143 *----------------------------------------------------------------------------- 144 * 145 * SvKeylgetObjCmd -- 146 * 147 * This procedure is invoked to process the "tsv::keylget" command. 148 * See the user documentation for details on what it does. 149 * 150 * Results: 151 * A standard Tcl result. 152 * 153 * Side effects: 154 * See the user documentation. 155 * 156 *----------------------------------------------------------------------------- 157 */ 158 159static int 160SvKeylgetObjCmd(arg, interp, objc, objv) 161 ClientData arg; /* Not used. */ 162 Tcl_Interp *interp; /* Current interpreter. */ 163 int objc; /* Number of arguments. */ 164 Tcl_Obj *const objv[]; /* Argument objects. */ 165{ 166 int ret, flg, off; 167 char *key; 168 Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL; 169 Container *svObj = (Container*)arg; 170 171 /* 172 * Syntax: 173 * sv::keylget array lkey ?key? ?var? 174 * $keylist keylget ?key? ?var? 175 */ 176 177 flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR; 178 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg); 179 if (ret != TCL_OK) { 180 return TCL_ERROR; 181 } 182 if ((objc - off) > 2) { 183 Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?"); 184 goto cmd_err; 185 } 186 if ((objc - off) == 0) { 187 if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) { 188 return TCL_ERROR; 189 } 190 return SvKeylkeysObjCmd(arg, interp, objc, objv); 191 } 192 if ((objc - off) == 2) { 193 varObjPtr = objv[off+1]; 194 } else { 195 varObjPtr = NULL; 196 } 197 198 key = Tcl_GetString(objv[off]); 199 ret = TclX_KeyedListGet(interp, svObj->tclObj, key, &valObjPtr); 200 if (ret == TCL_ERROR) { 201 goto cmd_err; 202 } 203 204 if (ret == TCL_BREAK) { 205 if (varObjPtr) { 206 Tcl_ResetResult(interp); 207 Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); 208 } else { 209 Tcl_AppendResult (interp, "key \"", key, "\" not found", NULL); 210 goto cmd_err; 211 } 212 } else { 213 Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr); 214 if (varObjPtr) { 215 int len; 216 Tcl_ResetResult(interp); 217 Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); 218 Tcl_GetStringFromObj(varObjPtr, &len); 219 if (len) { 220 Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0); 221 } 222 } else { 223 Tcl_SetObjResult(interp, resObjPtr); 224 } 225 } 226 227 return Sv_PutContainer(interp, svObj, SV_UNCHANGED); 228 229 cmd_err: 230 return Sv_PutContainer(interp, svObj, SV_ERROR); 231} 232 233/* 234 *----------------------------------------------------------------------------- 235 * 236 * SvKeyldelObjCmd -- 237 * 238 * This procedure is invoked to process the "tsv::keyldel" command. 239 * See the user documentation for details on what it does. 240 * 241 * Results: 242 * A standard Tcl result. 243 * 244 * Side effects: 245 * See the user documentation. 246 * 247 *----------------------------------------------------------------------------- 248 */ 249 250static int 251SvKeyldelObjCmd(arg, interp, objc, objv) 252 ClientData arg; /* Not used. */ 253 Tcl_Interp *interp; /* Current interpreter. */ 254 int objc; /* Number of arguments. */ 255 Tcl_Obj *const objv[]; /* Argument objects. */ 256{ 257 int i, off, ret; 258 char *key; 259 Container *svObj = (Container*)arg; 260 261 /* 262 * Syntax: 263 * sv::keyldel array lkey key ?key ...? 264 * $keylist keyldel ?key ...? 265 */ 266 267 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); 268 if (ret != TCL_OK) { 269 return TCL_ERROR; 270 } 271 if ((objc - off) < 1) { 272 Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?"); 273 goto cmd_err; 274 } 275 for (i = off; i < objc; i++) { 276 key = Tcl_GetString(objv[i]); 277 ret = TclX_KeyedListDelete(interp, svObj->tclObj, key); 278 if (ret == TCL_BREAK) { 279 Tcl_AppendResult(interp, "key \"", key, "\" not found", NULL); 280 } 281 if (ret == TCL_BREAK || ret == TCL_ERROR) { 282 goto cmd_err; 283 } 284 } 285 286 return Sv_PutContainer(interp, svObj, SV_CHANGED); 287 288 cmd_err: 289 return Sv_PutContainer(interp, svObj, SV_ERROR); 290} 291 292/* 293 *----------------------------------------------------------------------------- 294 * 295 * SvKeylkeysObjCmd -- 296 * 297 * This procedure is invoked to process the "tsv::keylkeys" command. 298 * See the user documentation for details on what it does. 299 * 300 * Results: 301 * A standard Tcl result. 302 * 303 * Side effects: 304 * See the user documentation. 305 * 306 *----------------------------------------------------------------------------- 307 */ 308 309static int 310SvKeylkeysObjCmd(arg, interp, objc, objv) 311 ClientData arg; /* Not used. */ 312 Tcl_Interp *interp; /* Current interpreter. */ 313 int objc; /* Number of arguments. */ 314 Tcl_Obj *const objv[]; /* Argument objects. */ 315{ 316 int ret, off; 317 char *key = NULL; 318 Tcl_Obj *listObj = NULL; 319 Container *svObj = (Container*)arg; 320 321 /* 322 * Syntax: 323 * sv::keylkeys array lkey ?key? 324 * $keylist keylkeys ?key? 325 */ 326 327 ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0); 328 if (ret != TCL_OK) { 329 return TCL_ERROR; 330 } 331 if ((objc - off) > 1) { 332 Tcl_WrongNumArgs(interp, 1, objv, "?lkey?"); 333 goto cmd_err; 334 } 335 if ((objc - off) == 1) { 336 key = Tcl_GetString(objv[off]); 337 } 338 339 ret = TclX_KeyedListGetKeys(interp, svObj->tclObj, key, &listObj); 340 341 if (key && ret == TCL_BREAK) { 342 Tcl_AppendResult(interp, "key \"", key, "\" not found", NULL); 343 } 344 if (ret == TCL_BREAK || ret == TCL_ERROR) { 345 goto cmd_err; 346 } 347 348 Tcl_SetObjResult (interp, listObj); /* listObj allocated by API !*/ 349 350 return Sv_PutContainer(interp, svObj, SV_UNCHANGED); 351 352 cmd_err: 353 return Sv_PutContainer(interp, svObj, SV_ERROR); 354} 355 356/* EOF $RCSfile: threadSvKeylistCmd.c,v $ */ 357 358/* Emacs Setup Variables */ 359/* Local Variables: */ 360/* mode: C */ 361/* indent-tabs-mode: nil */ 362/* c-basic-offset: 4 */ 363/* End: */ 364 365