fixes for tcl8.6 compatibility
1 | /* |
2 | * The contents of this file are subject to the AOLserver Public License |
3 | * Version 1.1 (the "License"); you may not use this file except in |
4 | * compliance with the License. You may obtain a copy of the License at |
5 | * http://aolserver.com/. |
6 | * |
7 | * Software distributed under the License is distributed on an "AS IS" |
8 | * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See |
9 | * the License for the specific language governing rights and limitations |
10 | * under the License. |
11 | * |
12 | * The Original Code is AOLserver Code and related documentation |
13 | * distributed by AOL. |
14 | * |
15 | * The Initial Developer of the Original Code is America Online, |
16 | * Inc. Portions created by AOL are Copyright (C) 1999 America Online, |
17 | * Inc. All Rights Reserved. |
18 | * |
19 | * Alternatively, the contents of this file may be used under the terms |
20 | * of the GNU General Public License (the "GPL"), in which case the |
21 | * provisions of GPL are applicable instead of those above. If you wish |
22 | * to allow use of your version of this file only under the terms of the |
23 | * GPL and not to allow others to use your version of this file under the |
24 | * License, indicate your decision by deleting the provisions above and |
25 | * replace them with the notice and other provisions required by the GPL. |
26 | * If you do not delete the provisions above, a recipient may use your |
27 | * version of this file under either the License or the GPL. |
28 | */ |
29 | |
30 | /* |
31 | * tclloop.c -- |
32 | * |
33 | * Replacements for the "for", "while", and "foreach" commands to be |
34 | * monitored and managed by "ns_loop_ctl" command. |
35 | */ |
36 | |
37 | static const char *RCSID = "@(#) $Header: /cvsroot-fuse/aolserver/aolserver/nsd/tclloop.c,v 1.4 2009/12/24 19:50:08 dvrsn Exp $, compiled: " __DATE__ " " __TIME__; |
38 | |
39 | #include "nsd.h" |
40 | |
41 | /* |
42 | * The following structure supports sending a script to a loop to eval. |
43 | */ |
44 | |
45 | typedef struct EvalData { |
46 | enum { |
47 | EVAL_WAIT, |
48 | EVAL_DONE, |
49 | EVAL_DROP |
50 | } state; /* Eval request state. */ |
51 | int code; /* Script result code. */ |
52 | Tcl_DString script; /* Script buffer. */ |
53 | Tcl_DString result; /* <a href="/cvs/aolserver/aolserver/nsd/tclresp.c#A_Result">Result</a> buffer. */ |
54 | } EvalData; |
55 | |
56 | /* |
57 | * The following structure is allocated for the "while" |
58 | * and "for" commands to maintain a copy of the current |
59 | * args and provide a cancel flag. |
60 | */ |
61 | |
62 | typedef struct LoopData { |
63 | enum { |
64 | LOOP_RUN, |
65 | LOOP_PAUSE, |
66 | LOOP_CANCEL |
67 | } control; /* Loop control commands. */ |
68 | unsigned int lid; /* Unique loop id. */ |
69 | int tid; /* Thread id of script. */ |
70 | unsigned int spins; /* Loop iterations. */ |
71 | Ns_Time etime; /* Loop entry time. */ |
72 | Tcl_HashEntry *hPtr; /* Entry in active loop table. */ |
73 | Tcl_DString args; /* Copy of command args. */ |
74 | EvalData *evalPtr; /* Eval request pending. */ |
75 | } LoopData; |
76 | |
77 | /* |
78 | * Static procedures defined in this file. |
79 | */ |
80 | |
81 | static int <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_CheckControl">CheckControl</a>(NsServer *servPtr, Tcl_Interp *interp, LoopData *dataPtr); |
82 | static void <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_EnterLoop">EnterLoop</a>(NsServer *servPtr, LoopData *dataPtr, int objc, |
83 | Tcl_Obj **objv); |
84 | static void <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_LeaveLoop">LeaveLoop</a>(NsServer *servPtr, LoopData *dataPtr); |
85 | |
86 | |
87 | /* |
88 | *---------------------------------------------------------------------- |
89 | * |
90 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclForObjCmd">NsTclForObjCmd</a> -- |
91 | * |
92 | * This procedure is invoked to process the "for" Tcl command. |
93 | * See the user documentation for details on what it does. |
94 | * |
95 | * With the bytecode compiler, this procedure is only called when |
96 | * a command name is computed at runtime, and is "for" or the name |
97 | * to which "for" was renamed: e.g., |
98 | * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" |
99 | * |
100 | * Copied from the Tcl source with additional calls to the |
101 | * loop control facility. |
102 | * |
103 | * Results: |
104 | * A standard Tcl result. |
105 | * |
106 | * Side effects: |
107 | * See the user documentation. |
108 | * |
109 | *---------------------------------------------------------------------- |
110 | */ |
111 | |
112 | int |
113 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclForObjCmd">NsTclForObjCmd</a>(arg, interp, objc, objv) |
114 | ClientData arg; /* Pointer to NsInterp. */ |
115 | Tcl_Interp *interp; /* Current interpreter. */ |
116 | int objc; /* Number of arguments. */ |
117 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
118 | { |
119 | NsInterp *itPtr = arg; |
120 | NsServer *servPtr = itPtr->servPtr; |
121 | LoopData data; |
122 | int result, value; |
123 | |
124 | if (objc != 5) { |
125 | Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); |
126 | return TCL_ERROR; |
127 | } |
128 | |
129 | result = Tcl_EvalObjEx(interp, objv[1], 0); |
130 | if (result != TCL_OK) { |
131 | if (result == TCL_ERROR) { |
132 | Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); |
133 | } |
134 | return result; |
135 | } |
136 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_EnterLoop">EnterLoop</a>(servPtr, &data, objc, objv); |
137 | while (1) { |
138 | /* |
139 | * We need to reset the result before passing it off to |
140 | * Tcl_ExprBooleanObj. Otherwise, any error message will be appended |
141 | * to the result of the last evaluation. |
142 | */ |
143 | |
144 | Tcl_ResetResult(interp); |
145 | result = Tcl_ExprBooleanObj(interp, objv[2], &value); |
146 | if (result != TCL_OK) { |
147 | goto done; |
148 | } |
149 | if (!value) { |
150 | break; |
151 | } |
152 | result = <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_CheckControl">CheckControl</a>(servPtr, interp, &data); |
153 | if (result == TCL_OK) { |
154 | result = Tcl_EvalObjEx(interp, objv[4], 0); |
155 | } |
156 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { |
157 | if (result == TCL_ERROR) { |
158 | char msg[32 + TCL_INTEGER_SPACE]; |
159 | |
160 | sprintf(msg, "\n (\"for\" body line %d)",Tcl_GetErrorLine(interp)); |
161 | Tcl_AddErrorInfo(interp, msg); |
162 | } |
163 | break; |
164 | } |
165 | result = Tcl_EvalObjEx(interp, objv[3], 0); |
166 | if (result == TCL_BREAK) { |
167 | break; |
168 | } else if (result != TCL_OK) { |
169 | if (result == TCL_ERROR) { |
170 | Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); |
171 | } |
172 | goto done; |
173 | } |
174 | } |
175 | if (result == TCL_BREAK) { |
176 | result = TCL_OK; |
177 | } |
178 | if (result == TCL_OK) { |
179 | Tcl_ResetResult(interp); |
180 | } |
181 | done: |
182 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_LeaveLoop">LeaveLoop</a>(servPtr, &data); |
183 | return result; |
184 | } |
185 | |
186 | |
187 | /* |
188 | *---------------------------------------------------------------------- |
189 | * |
190 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclWhileObjCmd">NsTclWhileObjCmd</a> -- |
191 | * |
192 | * This procedure is invoked to process the "while" Tcl command. |
193 | * See the user documentation for details on what it does. |
194 | * |
195 | * With the bytecode compiler, this procedure is only called when |
196 | * a command name is computed at runtime, and is "while" or the name |
197 | * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" |
198 | * |
199 | * Copied from the Tcl source with additional calls to the |
200 | * loop control facility. |
201 | * |
202 | * Results: |
203 | * A standard Tcl result. |
204 | * |
205 | * Side effects: |
206 | * See the user documentation. |
207 | * |
208 | *---------------------------------------------------------------------- |
209 | */ |
210 | |
211 | int |
212 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclWhileObjCmd">NsTclWhileObjCmd</a>(arg, interp, objc, objv) |
213 | ClientData arg; /* Pointer to NsInterp. */ |
214 | Tcl_Interp *interp; /* Current interpreter. */ |
215 | int objc; /* Number of arguments. */ |
216 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
217 | { |
218 | NsInterp *itPtr = arg; |
219 | NsServer *servPtr = itPtr->servPtr; |
220 | LoopData data; |
221 | int result, value; |
222 | |
223 | if (objc != 3) { |
224 | Tcl_WrongNumArgs(interp, 1, objv, "test command"); |
225 | return TCL_ERROR; |
226 | } |
227 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_EnterLoop">EnterLoop</a>(servPtr, &data, objc, objv); |
228 | while (1) { |
229 | result = Tcl_ExprBooleanObj(interp, objv[1], &value); |
230 | if (result != TCL_OK) { |
231 | goto done; |
232 | } |
233 | if (!value) { |
234 | break; |
235 | } |
236 | result = <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_CheckControl">CheckControl</a>(servPtr, interp, &data); |
237 | if (result == TCL_OK) { |
238 | result = Tcl_EvalObjEx(interp, objv[2], 0); |
239 | } |
240 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { |
241 | if (result == TCL_ERROR) { |
242 | char msg[32 + TCL_INTEGER_SPACE]; |
243 | |
244 | sprintf(msg, "\n (\"while\" body line %d)", |
245 | Tcl_GetErrorLine(interp)); |
246 | Tcl_AddErrorInfo(interp, msg); |
247 | } |
248 | break; |
249 | } |
250 | } |
251 | if (result == TCL_BREAK) { |
252 | result = TCL_OK; |
253 | } |
254 | if (result == TCL_OK) { |
255 | Tcl_ResetResult(interp); |
256 | } |
257 | done: |
258 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_LeaveLoop">LeaveLoop</a>(servPtr, &data); |
259 | return result; |
260 | } |
261 | |
262 | |
263 | /* |
264 | *---------------------------------------------------------------------- |
265 | * |
266 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclForeachObjCmd">NsTclForeachObjCmd</a> -- |
267 | * |
268 | * This object-based procedure is invoked to process the "foreach" Tcl |
269 | * command. See the user documentation for details on what it does. |
270 | * |
271 | * Results: |
272 | * A standard Tcl object result. |
273 | * |
274 | * Side effects: |
275 | * See the user documentation. |
276 | * |
277 | *---------------------------------------------------------------------- |
278 | */ |
279 | |
280 | int |
281 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclForeachObjCmd">NsTclForeachObjCmd</a>(arg, interp, objc, objv) |
282 | ClientData arg; /* Pointer to NsInterp. */ |
283 | Tcl_Interp *interp; /* Current interpreter. */ |
284 | int objc; /* Number of arguments. */ |
285 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
286 | { |
287 | NsInterp *itPtr = arg; |
288 | NsServer *servPtr = itPtr->servPtr; |
289 | LoopData data; |
290 | int result = TCL_OK; |
291 | int i; /* i selects a value list */ |
292 | int j, maxj; /* Number of loop iterations */ |
293 | int v; /* v selects a loop variable */ |
294 | int numLists; /* Count of value lists */ |
295 | Tcl_Obj *bodyPtr; |
296 | |
297 | /* |
298 | * We copy the argument object pointers into a local array to avoid |
299 | * the problem that "objv" might become invalid. It is a pointer into |
300 | * the evaluation stack and that stack might be grown and reallocated |
301 | * if the loop body requires a large amount of stack space. |
302 | */ |
303 | |
304 | #define NUM_ARGS 9 |
305 | Tcl_Obj *(argObjStorage[NUM_ARGS]); |
306 | Tcl_Obj **argObjv = argObjStorage; |
307 | |
308 | #define STATIC_LIST_SIZE 4 |
309 | int indexArray[STATIC_LIST_SIZE]; |
310 | int varcListArray[STATIC_LIST_SIZE]; |
311 | Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; |
312 | int argcListArray[STATIC_LIST_SIZE]; |
313 | Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; |
314 | |
315 | int *index = indexArray; /* Array of value list indices */ |
316 | int *varcList = varcListArray; /* # loop variables per list */ |
317 | Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */ |
318 | int *argcList = argcListArray; /* Array of value list sizes */ |
319 | Tcl_Obj ***argvList = argvListArray; /* Array of value lists */ |
320 | |
321 | if (objc < 4 || (objc%2 != 0)) { |
322 | Tcl_WrongNumArgs(interp, 1, objv, |
323 | "varList list ?varList list ...? command"); |
324 | return TCL_ERROR; |
325 | } |
326 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_EnterLoop">EnterLoop</a>(servPtr, &data, objc, objv); |
327 | |
328 | /* |
329 | * Create the object argument array "argObjv". Make sure argObjv is |
330 | * large enough to hold the objc arguments. |
331 | */ |
332 | |
333 | if (objc > NUM_ARGS) { |
334 | argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); |
335 | } |
336 | for (i = 0; i < objc; i++) { |
337 | argObjv[i] = objv[i]; |
338 | } |
339 | |
340 | /* |
341 | * Manage numList parallel value lists. |
342 | * argvList[i] is a value list counted by argcList[i] |
343 | * varvList[i] is the list of variables associated with the value list |
344 | * varcList[i] is the number of variables associated with the value list |
345 | * index[i] is the current pointer into the value list argvList[i] |
346 | */ |
347 | |
348 | numLists = (objc-2)/2; |
349 | if (numLists > STATIC_LIST_SIZE) { |
350 | index = (int *) ckalloc(numLists * sizeof(int)); |
351 | varcList = (int *) ckalloc(numLists * sizeof(int)); |
352 | varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); |
353 | argcList = (int *) ckalloc(numLists * sizeof(int)); |
354 | argvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **)); |
355 | } |
356 | for (i = 0; i < numLists; i++) { |
357 | index[i] = 0; |
358 | varcList[i] = 0; |
359 | varvList[i] = (Tcl_Obj **) NULL; |
360 | argcList[i] = 0; |
361 | argvList[i] = (Tcl_Obj **) NULL; |
362 | } |
363 | |
364 | /* |
365 | * Break up the value lists and variable lists into elements |
366 | */ |
367 | |
368 | maxj = 0; |
369 | for (i = 0; i < numLists; i++) { |
370 | result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], |
371 | &varcList[i], &varvList[i]); |
372 | if (result != TCL_OK) { |
373 | goto done; |
374 | } |
375 | if (varcList[i] < 1) { |
376 | Tcl_AppendToObj(Tcl_GetObjResult(interp), |
377 | "foreach varlist is empty", -1); |
378 | result = TCL_ERROR; |
379 | goto done; |
380 | } |
381 | |
382 | result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], |
383 | &argcList[i], &argvList[i]); |
384 | if (result != TCL_OK) { |
385 | goto done; |
386 | } |
387 | |
388 | j = argcList[i] / varcList[i]; |
389 | if ((argcList[i] % varcList[i]) != 0) { |
390 | j++; |
391 | } |
392 | if (j > maxj) { |
393 | maxj = j; |
394 | } |
395 | } |
396 | |
397 | /* |
398 | * Iterate maxj times through the lists in parallel |
399 | * If some value lists run out of values, set loop vars to "" |
400 | */ |
401 | |
402 | bodyPtr = argObjv[objc-1]; |
403 | for (j = 0; j < maxj; j++) { |
404 | for (i = 0; i < numLists; i++) { |
405 | /* |
406 | * Refetch the list members; we assume that the sizes are |
407 | * the same, but the array of elements might be different |
408 | * if the internal rep of the objects has been lost and |
409 | * recreated (it is too difficult to accurately tell when |
410 | * this happens, which can lead to some wierd crashes, |
411 | * like Bug #494348...) |
412 | */ |
413 | |
414 | result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], |
415 | &varcList[i], &varvList[i]); |
416 | if (result != TCL_OK) { |
417 | panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); |
418 | } |
419 | result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], |
420 | &argcList[i], &argvList[i]); |
421 | if (result != TCL_OK) { |
422 | panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); |
423 | } |
424 | |
425 | for (v = 0; v < varcList[i]; v++) { |
426 | int k = index[i]++; |
427 | Tcl_Obj *valuePtr, *varValuePtr; |
428 | |
429 | if (k < argcList[i]) { |
430 | valuePtr = argvList[i][k]; |
431 | } else { |
432 | valuePtr = Tcl_NewObj(); /* empty string */ |
433 | } |
434 | Tcl_IncrRefCount(valuePtr); |
435 | varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], |
436 | NULL, valuePtr, 0); |
437 | Tcl_DecrRefCount(valuePtr); |
438 | if (varValuePtr == NULL) { |
439 | Tcl_ResetResult(interp); |
440 | Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
441 | "couldn't set loop variable: \"", |
442 | Tcl_GetString(varvList[i][v]), "\"", (char *) NULL); |
443 | result = TCL_ERROR; |
444 | goto done; |
445 | } |
446 | |
447 | } |
448 | } |
449 | result = <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_CheckControl">CheckControl</a>(servPtr, interp, &data); |
450 | if (result == TCL_OK) { |
451 | result = Tcl_EvalObjEx(interp, bodyPtr, 0); |
452 | } |
453 | if (result != TCL_OK) { |
454 | if (result == TCL_CONTINUE) { |
455 | result = TCL_OK; |
456 | } else if (result == TCL_BREAK) { |
457 | result = TCL_OK; |
458 | break; |
459 | } else if (result == TCL_ERROR) { |
460 | char msg[32 + TCL_INTEGER_SPACE]; |
461 | |
462 | sprintf(msg, "\n (\"foreach\" body line %d)", |
463 | Tcl_GetErrorLine(interp)); |
464 | Tcl_AddObjErrorInfo(interp, msg, -1); |
465 | break; |
466 | } else { |
467 | break; |
468 | } |
469 | } |
470 | } |
471 | if (result == TCL_OK) { |
472 | Tcl_ResetResult(interp); |
473 | } |
474 | |
475 | done: |
476 | if (numLists > STATIC_LIST_SIZE) { |
477 | ckfree((char *) index); |
478 | ckfree((char *) varcList); |
479 | ckfree((char *) argcList); |
480 | ckfree((char *) varvList); |
481 | ckfree((char *) argvList); |
482 | } |
483 | if (argObjv != argObjStorage) { |
484 | ckfree((char *) argObjv); |
485 | } |
486 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_LeaveLoop">LeaveLoop</a>(servPtr, &data); |
487 | return result; |
488 | #undef STATIC_LIST_SIZE |
489 | #undef NUM_ARGS |
490 | } |
491 | |
492 | |
493 | /* |
494 | *---------------------------------------------------------------------- |
495 | * |
496 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclLoopCtlObjCmd">NsTclLoopCtlObjCmd</a> -- |
497 | * |
498 | * Control command to list all active for or while loops in |
499 | * any thread, get info (thread id and args) for an active |
500 | * loop, or signal cancel of a loop. |
501 | * |
502 | * Results: |
503 | * A standard Tcl result. |
504 | * |
505 | * Side effects: |
506 | * May cancel an active loop. Not cancel results in a |
507 | * TCL_ERROR result for the "for" or "while" command, |
508 | * an exception which can possibly be caught. |
509 | * |
510 | *---------------------------------------------------------------------- |
511 | */ |
512 | |
513 | int |
514 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclLoopCtlObjCmd">NsTclLoopCtlObjCmd</a>(arg, interp, objc, objv) |
515 | ClientData arg; /* Pointer to NsInterp. */ |
516 | Tcl_Interp *interp; /* Current interpreter. */ |
517 | int objc; /* Number of arguments. */ |
518 | Tcl_Obj *CONST objv[]; /* Argument objects. */ |
519 | { |
520 | NsInterp *itPtr = arg; |
521 | NsServer *servPtr = itPtr->servPtr; |
522 | LoopData *dataPtr; |
523 | EvalData eval; |
524 | Tcl_HashEntry *hPtr; |
525 | Tcl_HashSearch search; |
526 | Ns_Time timeout; |
527 | int lid, result, len, status; |
528 | char *str = ""; |
529 | Tcl_Obj *objPtr, *listPtr; |
530 | static CONST char *opts[] = { |
531 | "list", "info", "pause", "resume", "cancel", "eval", |
532 | "install", NULL |
533 | }; |
534 | enum { |
535 | LListIdx, LInfoIdx, LPauseIdx, LResumeIdx, LCancelIdx, LEvalIdx, |
536 | LInstallIdx |
537 | } opt; |
538 | static CONST char *copts[] = { |
539 | "for", "foreach", "while", NULL |
540 | }; |
541 | enum { |
542 | CForIdx, CForeachIdx, CWhileIdx |
543 | } copt; |
544 | static Tcl_ObjCmdProc *procs[] = { |
545 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclForObjCmd">NsTclForObjCmd</a>, <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclForeachObjCmd">NsTclForeachObjCmd</a>, <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_NsTclWhileObjCmd">NsTclWhileObjCmd</a> |
546 | }; |
547 | if (objc < 2) { |
548 | Tcl_WrongNumArgs(interp, 1, objv, "option ?id?"); |
549 | return TCL_ERROR; |
550 | } |
551 | if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, |
552 | (int *) &opt) != TCL_OK) { |
553 | return TCL_ERROR; |
554 | } |
555 | |
556 | /* |
557 | * Handle the list and install commands and verify arguments first. |
558 | */ |
559 | |
560 | switch (opt) { |
561 | case LListIdx: |
562 | if (objc != 2) { |
563 | Tcl_WrongNumArgs(interp, 2, objv, NULL); |
564 | return TCL_ERROR; |
565 | } |
566 | listPtr = Tcl_NewObj(); |
567 | Ns_MutexLock(&servPtr->tcl.llock); |
568 | hPtr = Tcl_FirstHashEntry(&servPtr->tcl.loops, &search); |
569 | while (hPtr != NULL) { |
570 | lid = (int) Tcl_GetHashKey(&servPtr->tcl.loops, hPtr); |
571 | objPtr = Tcl_NewIntObj(lid); |
572 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
573 | hPtr = Tcl_NextHashEntry(&search); |
574 | } |
575 | Ns_MutexUnlock(&servPtr->tcl.llock); |
576 | Tcl_SetObjResult(interp, listPtr); |
577 | return TCL_OK; |
578 | break; |
579 | |
580 | case LInstallIdx: |
581 | if (objc != 3) { |
582 | Tcl_WrongNumArgs(interp, 2, objv, "command"); |
583 | return TCL_ERROR; |
584 | } |
585 | if (Tcl_GetIndexFromObj(interp, objv[2], copts, "command", 0, |
586 | (int *) &copt) != TCL_OK) { |
587 | return TCL_ERROR; |
588 | } |
589 | Tcl_CreateObjCommand(interp, copts[copt], procs[copt], arg, NULL); |
590 | return TCL_OK; |
591 | break; |
592 | |
593 | case LEvalIdx: |
594 | if (objc != 4) { |
595 | Tcl_WrongNumArgs(interp, 2, objv, "id script"); |
596 | return TCL_ERROR; |
597 | } |
598 | break; |
599 | |
600 | default: |
601 | if (objc != 3) { |
602 | Tcl_WrongNumArgs(interp, 2, objv, "id"); |
603 | return TCL_ERROR; |
604 | } |
605 | break; |
606 | } |
607 | |
608 | /* |
609 | * All other commands require a loop id arg. |
610 | */ |
611 | |
612 | if (Tcl_GetIntFromObj(interp, objv[2], (int *) &lid) != TCL_OK) { |
613 | return TCL_ERROR; |
614 | } |
615 | result = TCL_OK; |
616 | Ns_MutexLock(&servPtr->tcl.llock); |
617 | hPtr = Tcl_FindHashEntry(&servPtr->tcl.loops, (char *) lid); |
618 | if (hPtr == NULL) { |
619 | switch (opt) { |
620 | case LInfoIdx: |
621 | case LEvalIdx: |
622 | Tcl_AppendResult(interp, "no such loop id: ", |
623 | Tcl_GetString(objv[2]), NULL); |
624 | result = TCL_ERROR; |
625 | break; |
626 | default: |
627 | Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0); |
628 | break; |
629 | } |
630 | goto done; |
631 | } |
632 | |
633 | dataPtr = Tcl_GetHashValue(hPtr); |
634 | switch (opt) { |
635 | case LInstallIdx: |
636 | case LListIdx: |
637 | /* NB: Silence warning. */ |
638 | break; |
639 | |
640 | case LInfoIdx: |
641 | /* |
642 | * Info format is: |
643 | * {loop id} {thread id} {start time} {status} {command args} |
644 | */ |
645 | |
646 | listPtr = Tcl_NewObj(); |
647 | objPtr = Tcl_NewIntObj(lid); |
648 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
649 | objPtr = Tcl_NewIntObj(dataPtr->tid); |
650 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
651 | objPtr = Tcl_NewObj(); |
652 | <a href="/cvs/aolserver/aolserver/nsd/tclobj.c#A_Ns_TclSetTimeObj">Ns_TclSetTimeObj</a>(objPtr, &dataPtr->etime); |
653 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
654 | objPtr = Tcl_NewIntObj(dataPtr->spins); |
655 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
656 | switch (dataPtr->control) { |
657 | case LOOP_RUN: |
658 | str = "running"; |
659 | break; |
660 | case LOOP_PAUSE: |
661 | str = "paused"; |
662 | break; |
663 | case LOOP_CANCEL: |
664 | str = "canceled"; |
665 | break; |
666 | } |
667 | objPtr = Tcl_NewStringObj(str, -1); |
668 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
669 | objPtr = Tcl_NewStringObj(dataPtr->args.string, dataPtr->args.length); |
670 | Tcl_ListObjAppendElement(interp, listPtr, objPtr); |
671 | Tcl_SetObjResult(interp, listPtr); |
672 | break; |
673 | |
674 | case LEvalIdx: |
675 | if (dataPtr->evalPtr != NULL) { |
676 | Tcl_SetResult(interp, "eval pending", TCL_STATIC); |
677 | result = TCL_ERROR; |
678 | goto done; |
679 | } |
680 | |
681 | /* |
682 | * <a href="/cvs/aolserver/aolserver/nsd/sockcallback.c#A_Queue">Queue</a> new script to eval. |
683 | */ |
684 | |
685 | eval.state = EVAL_WAIT; |
686 | eval.code = TCL_OK; |
687 | Tcl_DStringInit(&eval.result); |
688 | Tcl_DStringInit(&eval.script); |
689 | str = Tcl_GetStringFromObj(objv[3], &len); |
690 | Tcl_DStringAppend(&eval.script, str, len); |
691 | dataPtr->evalPtr = &eval; |
692 | |
693 | /* |
694 | * Wait for result. |
695 | */ |
696 | |
697 | Ns_GetTime(&timeout); |
698 | Ns_IncrTime(&timeout, 2, 0); |
699 | Ns_CondBroadcast(&servPtr->tcl.lcond); |
700 | status = NS_OK; |
701 | while (status == NS_OK && eval.state == EVAL_WAIT) { |
702 | status = Ns_CondTimedWait(&servPtr->tcl.lcond, |
703 | &servPtr->tcl.llock, &timeout); |
704 | } |
705 | switch (eval.state) { |
706 | case EVAL_WAIT: |
707 | Tcl_SetResult(interp, "timeout: result dropped", TCL_STATIC); |
708 | dataPtr->evalPtr = NULL; |
709 | result = TCL_ERROR; |
710 | break; |
711 | case EVAL_DROP: |
712 | Tcl_SetResult(interp, "dropped: loop exited", TCL_STATIC); |
713 | result = TCL_ERROR; |
714 | break; |
715 | case EVAL_DONE: |
716 | Tcl_DStringResult(interp, &eval.result); |
717 | result = eval.code; |
718 | } |
719 | Tcl_DStringFree(&eval.script); |
720 | Tcl_DStringFree(&eval.result); |
721 | break; |
722 | |
723 | case LResumeIdx: |
724 | case LPauseIdx: |
725 | case LCancelIdx: |
726 | if (opt == LCancelIdx) { |
727 | dataPtr->control = LOOP_CANCEL; |
728 | } else if (opt == LPauseIdx) { |
729 | dataPtr->control = LOOP_PAUSE; |
730 | } else { |
731 | dataPtr->control = LOOP_RUN; |
732 | } |
733 | Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1); |
734 | Ns_CondBroadcast(&servPtr->tcl.lcond); |
735 | break; |
736 | } |
737 | done: |
738 | Ns_MutexUnlock(&servPtr->tcl.llock); |
739 | return result; |
740 | } |
741 | |
742 | |
743 | /* |
744 | *---------------------------------------------------------------------- |
745 | * |
746 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_EnterLoop">EnterLoop</a> -- |
747 | * |
748 | * Add entry for the LoopData structure when a "for" or |
749 | * "while" command starts. |
750 | * |
751 | * Results: |
752 | * None. |
753 | * |
754 | * Side effects: |
755 | * Loop can be monitored and possibly canceled by "loop.ctl". |
756 | * |
757 | *---------------------------------------------------------------------- |
758 | */ |
759 | |
760 | static void |
761 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_EnterLoop">EnterLoop</a>(NsServer *servPtr, LoopData *dataPtr, int objc, Tcl_Obj **objv) |
762 | { |
763 | static unsigned int next = 0; |
764 | int i, new; |
765 | |
766 | dataPtr->control = LOOP_RUN; |
767 | dataPtr->spins = 0; |
768 | dataPtr->tid = Ns_ThreadId(); |
769 | dataPtr->evalPtr = NULL; |
770 | Ns_GetTime(&dataPtr->etime); |
771 | /* NB: Must copy strings in case loop body updates or invalidates them. */ |
772 | Tcl_DStringInit(&dataPtr->args); |
773 | for (i = 0; i < objc; ++i) { |
774 | Tcl_DStringAppendElement(&dataPtr->args, Tcl_GetString(objv[i])); |
775 | } |
776 | Ns_MutexLock(&servPtr->tcl.llock); |
777 | do { |
778 | dataPtr->lid = next++; |
779 | dataPtr->hPtr = Tcl_CreateHashEntry(&servPtr->tcl.loops, |
780 | (char *) dataPtr->lid, &new); |
781 | } while (!new); |
782 | Tcl_SetHashValue(dataPtr->hPtr, dataPtr); |
783 | Ns_MutexUnlock(&servPtr->tcl.llock); |
784 | } |
785 | |
786 | |
787 | /* |
788 | *---------------------------------------------------------------------- |
789 | * |
790 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_LeaveLoop">LeaveLoop</a> -- |
791 | * |
792 | * Remove entry for the LoopData structure when a "for" or |
793 | * "while" command exits. |
794 | * |
795 | * Results: |
796 | * None. |
797 | * |
798 | * Side effects: |
799 | * None. |
800 | * |
801 | *---------------------------------------------------------------------- |
802 | */ |
803 | |
804 | static void |
805 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_LeaveLoop">LeaveLoop</a>(NsServer *servPtr, LoopData *dataPtr) |
806 | { |
807 | Ns_MutexLock(&servPtr->tcl.llock); |
808 | if (dataPtr->evalPtr != NULL) { |
809 | dataPtr->evalPtr->state = EVAL_DROP; |
810 | Ns_CondBroadcast(&servPtr->tcl.lcond); |
811 | } |
812 | Tcl_DeleteHashEntry(dataPtr->hPtr); |
813 | Ns_MutexUnlock(&servPtr->tcl.llock); |
814 | Tcl_DStringFree(&dataPtr->args); |
815 | } |
816 | |
817 | |
818 | /* |
819 | *---------------------------------------------------------------------- |
820 | * |
821 | * <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_CheckControl">CheckControl</a> -- |
822 | * |
823 | * Check for control flag within a loop of a cancel or pause. |
824 | * |
825 | * Results: |
826 | * TCL_OK if not canceled, TCL_ERROR otherwise. |
827 | * |
828 | * Side effects: |
829 | * Leave cancel message as interp result. |
830 | * |
831 | *---------------------------------------------------------------------- |
832 | */ |
833 | |
834 | static int |
835 | <a href="/cvs/aolserver/aolserver/nsd/tclloop.c#A_CheckControl">CheckControl</a>(NsServer *servPtr, Tcl_Interp *interp, LoopData *dataPtr) |
836 | { |
837 | Tcl_DString script; |
838 | char *str; |
839 | int result, len; |
840 | |
841 | Ns_MutexLock(&servPtr->tcl.llock); |
842 | ++dataPtr->spins; |
843 | while (dataPtr->evalPtr != NULL || dataPtr->control == LOOP_PAUSE) { |
844 | if (dataPtr->evalPtr != NULL) { |
845 | Tcl_DStringInit(&script); |
846 | Tcl_DStringAppend(&script, dataPtr->evalPtr->script.string, |
847 | dataPtr->evalPtr->script.length); |
848 | Ns_MutexUnlock(&servPtr->tcl.llock); |
849 | result = Tcl_EvalEx(interp, script.string, script.length, 0); |
850 | Tcl_DStringFree(&script); |
851 | if (result != TCL_OK) { |
852 | <a href="/cvs/aolserver/aolserver/nsd/tclinit.c#A_Ns_TclLogError">Ns_TclLogError</a>(interp); |
853 | } |
854 | Ns_MutexLock(&servPtr->tcl.llock); |
855 | if (dataPtr->evalPtr == NULL) { |
856 | <a href="/cvs/aolserver/aolserver/nsd/log.c#A_Ns_Log">Ns_Log</a>(Error, "loopctl: dropped result: %s", Tcl_GetStringResult(interp)); |
857 | } else { |
858 | str = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); |
859 | Tcl_DStringAppend(&dataPtr->evalPtr->result, str, len); |
860 | dataPtr->evalPtr->state = EVAL_DONE; |
861 | dataPtr->evalPtr = NULL; |
862 | Ns_CondBroadcast(&servPtr->tcl.lcond); |
863 | } |
864 | } |
865 | if (dataPtr->control == LOOP_PAUSE) { |
866 | Ns_CondWait(&servPtr->tcl.lcond, &servPtr->tcl.llock); |
867 | } |
868 | } |
869 | if (dataPtr->control == LOOP_CANCEL) { |
870 | Tcl_SetResult(interp, "loop canceled", TCL_STATIC); |
871 | result = TCL_ERROR; |
872 | } else { |
873 | result = TCL_OK; |
874 | } |
875 | Ns_MutexUnlock(&servPtr->tcl.llock); |
876 | return result; |
877 | } |
Copyright © 2010 Geeknet, Inc. All rights reserved. Terms of Use