/* For free() */
17 |
18 | /*
19 | * Functions implementing the persistent store interface
20 | */
21 |
22 | static ps_open_proc ps_gdbm_open;
23 | static ps_close_proc ps_gdbm_close;
24 | static ps_get_proc ps_gdbm_get;
25 | static ps_put_proc ps_gdbm_put;
26 | static ps_first_proc ps_gdbm_first;
27 | static ps_next_proc ps_gdbm_next;
28 | static ps_delete_proc ps_gdbm_delete;
29 | static ps_free_proc ps_gdbm_free;
30 | static ps_geterr_proc ps_gdbm_geterr;
31 |
32 | /*
33 | * This structure collects all the various pointers
34 | * to the functions implementing the gdbm store.
35 | */
36 |
37 | PsStore GdbmStore = {
38 | "gdbm",
39 | NULL,
40 | ps_gdbm_open,
41 | ps_gdbm_get,
42 | ps_gdbm_put,
43 | ps_gdbm_first,
44 | ps_gdbm_next,
45 | ps_gdbm_delete,
46 | ps_gdbm_close,
47 | ps_gdbm_free,
48 | ps_gdbm_geterr,
49 | NULL
50 | };
51 |
52 | /*
53 | *-----------------------------------------------------------------------------
54 | *
55 | * Sv_RegisterGdbmStore --
56 | *
57 | * Register the gdbm store with shared variable implementation.
58 | *
59 | * Results:
60 | * None.
61 | *
62 | * Side effects:
63 | * None.
64 | *
65 | *-----------------------------------------------------------------------------
66 | */
67 | void
68 | Sv_RegisterGdbmStore(void)
69 | {
70 | Sv_RegisterPsStore(&GdbmStore);
71 | }
72 |
73 | /*
74 | *-----------------------------------------------------------------------------
75 | *
76 | * ps_gdbm_open --
77 | *
78 | * Opens the dbm-based persistent storage.
79 | *
80 | * Results:
81 | * Opaque handle of the opened dbm storage.
82 | *
83 | * Side effects:
84 | * The gdbm file might be created if not found.
85 | *
86 | *-----------------------------------------------------------------------------
87 | */
88 | static ClientData
89 | ps_gdbm_open(path)
90 | const char *path;
91 | {
92 | GDBM_FILE dbf;
93 | char *ext;
94 | Tcl_DString toext;
95 |
96 | Tcl_DStringInit(&toext);
97 | ext = Tcl_UtfToExternalDString(NULL, (char*)path, strlen(path), &toext);
98 | dbf = gdbm_open(ext, 512, GDBM_WRCREAT|GDBM_SYNC|GDBM_NOLOCK, 0666, NULL);
99 | Tcl_DStringFree(&toext);
100 |
101 | return (ClientData)dbf;
102 | }
103 |
104 | /*
105 | *-----------------------------------------------------------------------------
106 | *
107 | * ps_gdbm_close --
108 | *
109 | * Closes the gdbm-based persistent storage.
110 | *
111 | * Results:
112 | * 0 - ok
113 | *
114 | * Side effects:
115 | * None.
116 | *
117 | *-----------------------------------------------------------------------------
118 | */
119 | static int
120 | ps_gdbm_close(handle)
121 | ClientData handle;
122 | {
123 | gdbm_close((GDBM_FILE)handle);
124 |
125 | return 0;
126 | }
127 |
128 | /*
129 | *-----------------------------------------------------------------------------
130 | *
131 | * ps_gdbm_get --
132 | *
133 | * Retrieves data for the key from the dbm storage.
134 | *
135 | * Results:
136 | * 1 - no such key
137 | * 0 - ok
138 | *
139 | * Side effects:
140 | * Data returned must be freed by the caller.
141 | *
142 | *-----------------------------------------------------------------------------
143 | */
144 | static int
145 | ps_gdbm_get(handle, key, dataptrptr, lenptr)
146 | ClientData handle;
147 | const char *key;
148 | char **dataptrptr;
149 | int *lenptr;
150 | {
151 | GDBM_FILE dbf = (GDBM_FILE)handle;
152 | datum drec, dkey;
153 |
154 | dkey.dptr = (char*)key;
155 | dkey.dsize = strlen(key) + 1;
156 |
157 | drec = gdbm_fetch(dbf, dkey);
158 | if (drec.dptr == NULL) {
159 | return 1;
160 | }
161 |
162 | *dataptrptr = drec.dptr;
163 | *lenptr = drec.dsize;
164 |
165 | return 0;
166 | }
167 |
168 | /*
169 | *-----------------------------------------------------------------------------
170 | *
171 | * ps_gdbm_first --
172 | *
173 | * Starts the iterator over the dbm file and returns the first record.
174 | *
175 | * Results:
176 | * 1 - no more records in the iterator
177 | * 0 - ok
178 | *
179 | * Side effects:
180 | * Data returned must be freed by the caller.
181 | *
182 | *-----------------------------------------------------------------------------
183 | */
184 | static int
185 | ps_gdbm_first(handle, keyptrptr, dataptrptr, lenptr)
186 | ClientData handle;
187 | char **keyptrptr;
188 | char **dataptrptr;
189 | int *lenptr;
190 | {
191 | GDBM_FILE dbf = (GDBM_FILE)handle;
192 | datum drec, dkey;
193 |
194 | dkey = gdbm_firstkey(dbf);
195 | if (dkey.dptr == NULL) {
196 | return 1;
197 | }
198 | drec = gdbm_fetch(dbf, dkey);
199 | if (drec.dptr == NULL) {
200 | return 1;
201 | }
202 |
203 | *dataptrptr = drec.dptr;
204 | *lenptr = drec.dsize;
205 | *keyptrptr = dkey.dptr;
206 |
207 | return 0;
208 | }
209 |
210 | /*
211 | *-----------------------------------------------------------------------------
212 | *
213 | * ps_gdbm_next --
214 | *
215 | * Uses the iterator over the dbm file and returns the next record.
216 | *
217 | * Results:
218 | * 1 - no more records in the iterator
219 | * 0 - ok
220 | *
221 | * Side effects:
222 | * Data returned must be freed by the caller.
223 | *
224 | *-----------------------------------------------------------------------------
225 | */
226 | static int ps_gdbm_next(handle, keyptrptr, dataptrptr, lenptr)
227 | ClientData handle;
228 | char **keyptrptr;
229 | char **dataptrptr;
230 | int *lenptr;
231 | {
232 | GDBM_FILE dbf = (GDBM_FILE)handle;
233 | datum drec, dkey, dnext;
234 |
235 | dkey.dptr = *keyptrptr;
236 | dkey.dsize = strlen(*keyptrptr) + 1;
237 |
238 | dnext = gdbm_nextkey(dbf, dkey);
239 | free(*keyptrptr), *keyptrptr = NULL;
240 |
241 | if (dnext.dptr == NULL) {
242 | return 1;
243 | }
244 | drec = gdbm_fetch(dbf, dnext);
245 | if (drec.dptr == NULL) {
246 | return 1;
247 | }
248 |
249 | *dataptrptr = drec.dptr;
250 | *lenptr = drec.dsize;
251 | *keyptrptr = dnext.dptr;
252 |
253 | return 0;
254 | }
255 |
256 | /*
257 | *-----------------------------------------------------------------------------
258 | *
259 | * ps_gdbm_put --
260 | *
261 | * Stores used data bound to a key in dbm storage.
262 | *
263 | * Results:
264 | * 0 - ok
265 | * -1 - error; use ps_dbm_geterr to retrieve the error message
266 | *
267 | * Side effects:
268 | * If the key is already associated with some user data, this will
269 | * be replaced by the new data chunk.
270 | *
271 | *-----------------------------------------------------------------------------
272 | */
273 | static int
274 | ps_gdbm_put(handle, key, dataptr, len)
275 | ClientData handle;
276 | const char *key;
277 | char *dataptr;
278 | int len;
279 | {
280 | GDBM_FILE dbf = (GDBM_FILE)handle;
281 | datum drec, dkey;
282 | int ret;
283 |
284 | dkey.dptr = (char*)key;
285 | dkey.dsize = strlen(key) + 1;
286 |
287 | drec.dptr = dataptr;
288 | drec.dsize = len;
289 |
290 | ret = gdbm_store(dbf, dkey, drec, GDBM_REPLACE);
291 | if (ret == -1) {
292 | return -1;
293 | }
294 |
295 | return 0;
296 | }
297 |
298 | /*
299 | *-----------------------------------------------------------------------------
300 | *
301 | * ps_gdbm_delete --
302 | *
303 | * Deletes the key and associated data from the dbm storage.
304 | *
305 | * Results:
306 | * 0 - ok
307 | * -1 - error; use ps_dbm_geterr to retrieve the error message
308 | *
309 | * Side effects:
310 | * If the key is already associated with some user data, this will
311 | * be replaced by the new data chunk.
312 | *
313 | *-----------------------------------------------------------------------------
314 | */
315 | static int
316 | ps_gdbm_delete(handle, key)
317 | ClientData handle;
318 | const char *key;
319 | {
320 | GDBM_FILE dbf = (GDBM_FILE)handle;
321 | datum dkey;
322 | int ret;
323 |
324 | dkey.dptr = (char*)key;
325 | dkey.dsize = strlen(key) + 1;
326 |
327 | ret = gdbm_delete(dbf, dkey);
328 | if (ret == -1) {
329 | return -1;
330 | }
331 |
332 | return 0;
333 | }
334 |
335 | /*
336 | *-----------------------------------------------------------------------------
337 | *
338 | * ps_gdbm_free --
339 | *
340 | * Frees memory allocated by the gdbm implementation.
341 | *
342 | * Results:
343 | * None.
344 | *
345 | * Side effects:
346 | * Memory gets reclaimed.
347 | *
348 | *-----------------------------------------------------------------------------
349 | */
350 | static void
351 | ps_gdbm_free(data)
352 | char *data;
353 | {
354 | free(data);
355 | }
356 |
357 | /*
358 | *-----------------------------------------------------------------------------
359 | *
360 | * ps_gdbm_geterr --
361 | *
362 | * Retrieves the textual representation of the error caused
363 | * by the last dbm command.
364 | *
365 | * Results:
366 | * Pointer to the strimg message.
367 | *
368 | * Side effects:
369 | * None.
370 | *
371 | *-----------------------------------------------------------------------------
372 | */
373 | static char*
374 | ps_gdbm_geterr(handle)
375 | ClientData handle;
376 | {
377 | /*
378 | * The problem with gdbm interface is that it uses the global
379 | * gdbm_errno variable which is not per-thread nor mutex
380 | * protected. This variable is used to reference array of gdbm
381 | * error text strings. It is very dangeours to use this in the
382 | * MT-program without proper locking. For this kind of app
383 | * we should not be concerned with that, since all ps_gdbm_xxx
384 | * operations are performed under shared variable lock anyway.
385 | */
386 |
387 | return gdbm_strerror(gdbm_errno);
388 | }
389 |
390 | #endif /* HAVE_GDBM */
391 |
392 | /* EOF $RCSfile*/
393 |
394 | /* Emacs Setup Variables */
395 | /* Local Variables: */
396 | /* mode: C */
397 | /* indent-tabs-mode: nil */
398 | /* c-basic-offset: 4 */
399 | /* End: */
400 |
--------------------------------------------------------------------------------
/doc/tpool.man:
--------------------------------------------------------------------------------
1 | [comment {-*- tcl -*- doctools manpage}]
2 | [manpage_begin tpool n 2.6]
3 | [moddesc {Tcl Threading}]
4 | [titledesc {Part of the Tcl threading extension implementing pools of worker threads.}]
5 | [require Tcl 8.4]
6 | [require Thread [opt 2.6]]
7 |
8 | [description]
9 | This package creates and manages pools of worker threads. It allows you
10 | to post jobs to worker threads and wait for their completion. The
11 | threadpool implementation is Tcl event-loop aware. That means that any
12 | time a caller is forced to wait for an event (job being completed or
13 | a worker thread becoming idle or initialized), the implementation will
14 | enter the event loop and allow for servicing of other pending file or
15 | timer (or any other supported) events.
16 |
17 | [section COMMANDS]
18 |
19 | [list_begin definitions]
20 |
21 | [call [cmd tpool::create] [opt options]]
22 |
23 | This command creates new threadpool. It accepts several options as
24 | key-value pairs. Options are used to tune some threadpool parameters.
25 | The command returns the ID of the newly created threadpool.
26 | [para]
27 | Following options are supported:
28 |
29 | [list_begin options]
30 |
31 | [opt_def -minworkers [arg number]]
32 | Minimum number of worker threads needed for this threadpool instance.
33 | During threadpool creation, the implementation will create somany
34 | worker threads upfront and will keep at least number of them alive
35 | during the lifetime of the threadpool instance.
36 | Default value of this parameter is 0 (zero). which means that a newly
37 | threadpool will have no worker threads initialy. All worker threads
38 | will be started on demand by callers running [cmd tpool::post] command
39 | and posting jobs to the job queue.
40 |
41 | [opt_def -maxworkers [arg number]]
42 | Maximum number of worker threads allowed for this threadpool instance.
43 | If a new job is pending and there are no idle worker threads available,
44 | the implementation will try to create new worker thread. If the number
45 | of available worker threads is lower than the given number,
46 | new worker thread will start. The caller will automatically enter the
47 | event loop and wait until the worker thread has initialized. If. however,
48 | the number of available worker threads is equal to the given number,
49 | the caller will enter the event loop and wait for the first worker thread
50 | to get idle, thus ready to run the job.
51 | Default value of this parameter is 4 (four), which means that the
52 | threadpool instance will allow maximum of 4 worker threads running jobs
53 | or being idle waiting for new jobs to get posted to the job queue.
54 |
55 | [opt_def -idletime [arg seconds]]
56 | Time in seconds an idle worker thread waits for the job to get posted
57 | to the job queue. If no job arrives during this interval and the time
58 | expires, the worker thread will check the number of currently available
59 | worker threads and if the number is higher than the number set by the
60 | [option minthreads] option, it will exit.
61 | If an [option exitscript] has been defined, the exiting worker thread
62 | will first run the script and then exit. Errors from the exit script,
63 | if any, are ignored.
64 | [para]
65 | The idle worker thread is not servicing the event loop. If you, however,
66 | put the worker thread into the event loop, by evaluating the
67 | [cmd vwait] or other related Tcl commands, the worker thread
68 | will not be in the idle state, hence the idle timer will not be
69 | taken into account.
70 | Default value for this option is unspecified, hence, the Tcl interpreter
71 | of the worker thread will contain just the initial set of Tcl commands.
72 |
73 | [opt_def -initcmd [arg script]]
74 | Sets a Tcl script used to initialize new worker thread. This is usually
75 | used to load packages and commands in the worker, set default variables,
76 | create namespaces, and such. If the passed script runs into a Tcl error,
77 | the worker will not be created and the initiating command (either the
78 | [cmd tpool::create] or [cmd tpool::post]) will throw error.
79 | Default value for this option is unspecified, hence, the Tcl interpreter of
80 | the worker thread will contain just the initial set of Tcl commands.
81 |
82 | [opt_def -exitcmd [arg script]]
83 | Sets a Tcl script run when the idle worker thread exits. This is normaly
84 | used to cleanup the state of the worker thread, release reserved resources,
85 | cleanup memory and such.
86 | Default value for this option is unspecified, thus no Tcl script will run
87 | on the worker thread exit.
88 |
89 | [list_end]
90 |
91 | [para]
92 |
93 | [call [cmd tpool::names]]
94 |
95 | This command returns a list of IDs of threadpools created with the
96 | [cmd tpool::create] command. If no threadpools were found, the
97 | command will return empty list.
98 |
99 | [call [cmd tpool::post] [opt -detached] [opt -nowait] [arg tpool] [arg script]]
100 |
101 | This command sends a [arg script] to the target [arg tpool] threadpool
102 | for execution. The script will be executed in the first available idle
103 | worker thread. If there are no idle worker threads available, the command
104 | will create new one, enter the event loop and service events until the
105 | newly created thread is initialized. If the current number of worker
106 | threads is equal to the maximum number of worker threads, as defined
107 | during the threadpool creation, the command will enter the event loop and
108 | service events while waiting for one of the worker threads to become idle.
109 | If the optional [opt -nowait] argument is given, the command will not wait
110 | for one idle worker. It will just place the job in the pool's job queue
111 | and return immediately.
112 | [para]
113 | The command returns the ID of the posted job. This ID is used for subsequent
114 | [cmd tpool::wait], [cmd tpool::get] and [cmd tpool::cancel] commands to wait
115 | for and retrieve result of the posted script, or cancel the posted job
116 | respectively. If the optional [opt -detached] argument is specified, the
117 | command will post a detached job. A detached job can not be cancelled or
118 | waited upon and is not identified by the job ID.
119 | [para]
120 | If the threadpool [arg tpool] is not found in the list of active
121 | thread pools, the command will throw error. The error will also be triggered
122 | if the newly created worker thread fails to initialize.
123 |
124 | [call [cmd tpool::wait] [arg tpool] [arg joblist] [opt varname]]
125 |
126 | This command waits for one or many jobs, whose job IDs are given in the
127 | [arg joblist] to get processed by the worker thread(s). If none of the
128 | specified jobs are ready, the command will enter the event loop, service
129 | events and wait for the first job to get ready.
130 | [para]
131 | The command returns the list of completed job IDs. If the optional variable
132 | [opt varname] is given, it will be set to the list of jobs in the
133 | [arg joblist] which are still pending. If the threadpool [arg tpool]
134 | is not found in the list of active thread pools, the command will throw error.
135 |
136 | [call [cmd tpool::cancel] [arg tpool] [arg joblist] [opt varname]]
137 |
138 | This command cancels the previously posted jobs given by the [arg joblist]
139 | to the pool [arg tpool]. Job cancellation succeeds only for job still
140 | waiting to be processed. If the job is already being executed by one of
141 | the worker threads, the job will not be cancelled.
142 | The command returns the list of cancelled job IDs. If the optional variable
143 | [opt varname] is given, it will be set to the list of jobs in the
144 | [arg joblist] which were not cancelled. If the threadpool [arg tpool]
145 | is not found in the list of active thread pools, the command will throw error.
146 |
147 | [call [cmd tpool::get] [arg tpool] [arg job]]
148 |
149 | This command retrieves the result of the previously posted [arg job].
150 | Only results of jobs waited upon with the [cmd tpool::wait] command
151 | can be retrieved. If the execution of the script resulted in error,
152 | the command will throw the error and update the [var errorInfo] and
153 | [var errorCode] variables correspondingly. If the pool [arg tpool]
154 | is not found in the list of threadpools, the command will throw error.
155 | If the job [arg job] is not ready for retrieval, because it is currently
156 | being executed by the worker thread, the command will throw error.
157 |
158 | [call [cmd tpool::preserve] [arg tpool]]
159 |
160 | Each call to this command increments the reference counter of the
161 | threadpool [arg tpool] by one (1). Command returns the value of the
162 | reference counter after the increment.
163 | By incrementing the reference counter, the caller signalizes that
164 | he/she wishes to use the resource for a longer period of time.
165 |
166 | [call [cmd tpool::release] [arg tpool]]
167 |
168 | Each call to this command decrements the reference counter of the
169 | threadpool [arg tpool] by one (1).Command returns the value of the
170 | reference counter after the decrement.
171 | When the reference counter reaches zero (0), the threadpool [arg tpool]
172 | is marked for termination. You should not reference the threadpool
173 | after the [cmd tpool::release] command returns zero. The [arg tpool]
174 | handle goes out of scope and should not be used any more. Any following
175 | reference to the same threadpool handle will result in Tcl error.
176 |
177 | [call [cmd tpool::suspend] [arg tpool]]
178 |
179 | Suspends processing work on this queue. All pool workers are paused
180 | but additional work can be added to the pool. Note that adding the
181 | additional work will not increase the number of workers dynamically
182 | as the pool processing is suspended. Number of workers is maintained
183 | to the count that was found prior suspending worker activity.
184 | If you need to assure certain number of worker threads, use the
185 | [option minworkers] option of the [cmd tpool::create] command.
186 |
187 | [call [cmd tpool::resume] [arg tpool]]
188 |
189 | Resume processing work on this queue. All paused (suspended)
190 | workers are free to get work from the pool. Note that resuming pool
191 | operation will just let already created workers to proceed.
192 | It will not create additional worker threads to handle the work
193 | posted to the pool's work queue.
194 |
195 | [list_end]
196 |
197 |
198 | [section DISCUSSION]
199 |
200 | Threadpool is one of the most common threading paradigm when it comes
201 | to server applications handling a large number of relatively small tasks.
202 | A very simplistic model for building a server application would be to
203 | create a new thread each time a request arrives and service the request
204 | in the new thread. One of the disadvantages of this approach is that
205 | the overhead of creating a new thread for each request is significant;
206 | a server that created a new thread for each request would spend more time
207 | and consume more system resources in creating and destroying threads than
208 | in processing actual user requests. In addition to the overhead of
209 | creating and destroying threads, active threads consume system resources.
210 | Creating too many threads can cause the system to run out of memory or
211 | trash due to excessive memory consumption.
212 | [para]
213 | A thread pool offers a solution to both the problem of thread life-cycle
214 | overhead and the problem of resource trashing. By reusing threads for
215 | multiple tasks, the thread-creation overhead is spread over many tasks.
216 | As a bonus, because the thread already exists when a request arrives,
217 | the delay introduced by thread creation is eliminated. Thus, the request
218 | can be serviced immediately. Furthermore, by properly tuning the number
219 | of threads in the thread pool, resource thrashing may also be eliminated
220 | by forcing any request to wait until a thread is available to process it.
221 |
222 | [see_also tsv ttrace thread]
223 |
224 | [keywords thread threadpool]
225 |
226 | [manpage_end]
227 |
--------------------------------------------------------------------------------
/generic/threadSvKeylistCmd.c:
--------------------------------------------------------------------------------
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$
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 |
30 | extern Tcl_ObjType keyedListType;
31 |
32 | /*
33 | * Wrapped keyed-list commands
34 | */
35 |
36 | static Tcl_ObjCmdProc SvKeylsetObjCmd;
37 | static Tcl_ObjCmdProc SvKeylgetObjCmd;
38 | static Tcl_ObjCmdProc SvKeyldelObjCmd;
39 | static Tcl_ObjCmdProc SvKeylkeysObjCmd;
40 |
41 | /*
42 | * This mutex protects a static variable which tracks
43 | * registration of commands and object types.
44 | */
45 |
46 | static 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 | */
64 | void
65 | Sv_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 |
100 | static int
101 | SvKeylsetObjCmd(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 |
159 | static int
160 | SvKeylgetObjCmd(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 |
250 | static int
251 | SvKeyldelObjCmd(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 |
309 | static int
310 | SvKeylkeysObjCmd(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$ */
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 |
--------------------------------------------------------------------------------
/tcl/phttpd/uhttpd.tcl:
--------------------------------------------------------------------------------
1 | #
2 | # uhttpd.tcl --
3 | #
4 | # Simple Sample httpd/1.0 server in 250 lines of Tcl.
5 | # Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
6 | #
7 | # Modified to use namespaces and direct url-to-procedure access (zv).
8 | # Eh, due to this, and nicer indenting, it's now 150 lines longer :-)
9 | #
10 | # Usage:
11 | # phttpd::create port
12 | #
13 | # port Tcp port where the server listens
14 | #
15 | # Example:
16 | #
17 | # # tclsh8.4
18 | # % source uhttpd.tcl
19 | # % uhttpd::create 5000
20 | # % vwait forever
21 | #
22 | # Starts the server on the port 5000. Also, look at the Httpd array
23 | # definition in the "uhttpd" namespace declaration to find out
24 | # about other options you may put on the command line.
25 | #
26 | # You can use: http://localhost:5000/monitor URL to test the
27 | # server functionality.
28 | #
29 | # Copyright (c) Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
30 | # Copyright (c) 2002 by Zoran Vasiljevic.
31 | #
32 | # See the file "license.terms" for information on usage and
33 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
34 | #
35 | # -----------------------------------------------------------------------------
36 | # Rcsid: @(#)$Id$
37 | #
38 |
39 | namespace eval uhttpd {
40 |
41 | variable Httpd; # Internal server state and config params
42 | variable MimeTypes; # Cache of file-extension/mime-type
43 | variable HttpCodes; # Portion of well-known http return codes
44 | variable ErrorPage; # Format of error response page in html
45 |
46 | array set Httpd {
47 | -name uhttpd
48 | -vers 1.0
49 | -root ""
50 | -index index.htm
51 | }
52 | array set HttpCodes {
53 | 400 "Bad Request"
54 | 401 "Not Authorized"
55 | 404 "Not Found"
56 | 500 "Server error"
57 | }
58 | array set MimeTypes {
59 | {} "text/plain"
60 | .txt "text/plain"
61 | .htm "text/html"
62 | .htm "text/html"
63 | .gif "image/gif"
64 | .jpg "image/jpeg"
65 | .png "image/png"
66 | }
67 | set ErrorPage {
68 | Error: %1$s %2$s
69 | %3$s
70 | Problem in accessing "%4$s" on this server.
71 |
72 | %5$s/%6$s Server at %7$s Port %8$s
73 | }
74 | }
75 |
76 | proc uhttpd::create {port args} {
77 |
78 | # @c Start the server by listening for connections on the desired port.
79 |
80 | variable Httpd
81 | set arglen [llength $args]
82 |
83 | if {$arglen} {
84 | if {$arglen % 2} {
85 | error "wrong \# arguments, should be: key1 val1 key2 val2..."
86 | }
87 | set opts [array names Httpd]
88 | foreach {arg val} $args {
89 | if {[lsearch $opts $arg] == -1} {
90 | error "unknown option \"$arg\""
91 | }
92 | set Httpd($arg) $val
93 | }
94 | }
95 |
96 | set Httpd(port) $port
97 | set Httpd(host) [info hostname]
98 |
99 | socket -server [namespace current]::Accept $port
100 | }
101 |
102 | proc uhttpd::respond {s status contype data {length 0}} {
103 |
104 | puts $s "HTTP/1.0 $status"
105 | puts $s "Date: [Date]"
106 | puts $s "Content-Type: $contype"
107 |
108 | if {$length} {
109 | puts $s "Content-Length: $length"
110 | } else {
111 | puts $s "Content-Length: [string length $data]"
112 | }
113 |
114 | puts $s ""
115 | puts $s $data
116 | }
117 |
118 | proc uhttpd::Accept {newsock ipaddr port} {
119 |
120 | # @c Accept a new connection from the client.
121 |
122 | variable Httpd
123 | upvar \#0 [namespace current]::Httpd$newsock data
124 |
125 | fconfigure $newsock -blocking 0 -translation {auto crlf}
126 |
127 | set data(ipaddr) $ipaddr
128 | fileevent $newsock readable [list [namespace current]::Read $newsock]
129 | }
130 |
131 | proc uhttpd::Read {s} {
132 |
133 | # @c Read data from client
134 |
135 | variable Httpd
136 | upvar \#0 [namespace current]::Httpd$s data
137 |
138 | if {[catch {gets $s line} readCount] || [eof $s]} {
139 | return [Done $s]
140 | }
141 | if {$readCount == -1} {
142 | return ;# Insufficient data on non-blocking socket !
143 | }
144 | if {![info exists data(state)]} {
145 | set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]}
146 | if {[regexp $pat $line x data(proto) data(url) data(query)]} {
147 | return [set data(state) mime]
148 | } else {
149 | Log error "bad request line: %s" $line
150 | Error $s 400
151 | return [Done $s]
152 | }
153 | }
154 |
155 | # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
156 |
157 | set state [string compare $readCount 0],$data(state),$data(proto)
158 | switch -- $state {
159 | "0,mime,GET" - "0,query,POST" {
160 | Respond $s
161 | }
162 | "0,mime,POST" {
163 | set data(state) query
164 | set data(query) ""
165 | }
166 | "1,mime,POST" - "1,mime,GET" {
167 | if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
168 | set data(mime,[string tolower $key]) $value
169 | }
170 | }
171 | "1,query,POST" {
172 | append data(query) $line
173 | set clen $data(mime,content-length)
174 | if {($clen - [string length $data(query)]) <= 0} {
175 | Respond $s
176 | }
177 | }
178 | default {
179 | if [eof $s] {
180 | Log error "unexpected eof; client closed connection"
181 | return [Done $s]
182 | } else {
183 | Log error "bad http protocol state: %s" $state
184 | Error $s 400
185 | return [Done $s]
186 | }
187 | }
188 | }
189 | }
190 |
191 | proc uhttpd::Done {s} {
192 |
193 | # @c Close the connection socket and discard token
194 |
195 | close $s
196 | unset [namespace current]::Httpd$s
197 | }
198 |
199 | proc uhttpd::Respond {s} {
200 |
201 | # @c Respond to the query.
202 |
203 | variable Httpd
204 | upvar \#0 [namespace current]::Httpd$s data
205 |
206 | if {[uplevel \#0 info proc $data(url)] == $data(url)} {
207 |
208 | #
209 | # Service URL-procedure first
210 | #
211 |
212 | if {[catch {
213 | puts $s "HTTP/1.0 200 OK"
214 | puts $s "Date: [Date]"
215 | puts $s "Last-Modified: [Date]"
216 | } err]} {
217 | Log error "client closed connection prematurely: %s" $err
218 | return [Done $s]
219 | }
220 | set data(sock) $s
221 | if {[catch {$data(url) data} err]} {
222 | Log error "%s: %s" $data(url) $err
223 | }
224 |
225 | } else {
226 |
227 | #
228 | # Service regular file path next.
229 | #
230 |
231 | set mypath [Url2File $data(url)]
232 | if {![catch {open $mypath} i]} {
233 | if {[catch {
234 | puts $s "HTTP/1.0 200 OK"
235 | puts $s "Date: [Date]"
236 | puts $s "Last-Modified: [Date [file mtime $mypath]]"
237 | puts $s "Content-Type: [ContentType $mypath]"
238 | puts $s "Content-Length: [file size $mypath]"
239 | puts $s ""
240 | fconfigure $s -translation binary -blocking 0
241 | fconfigure $i -translation binary
242 | fcopy $i $s
243 | close $i
244 | } err]} {
245 | Log error "client closed connection prematurely: %s" $err
246 | }
247 | } else {
248 | Log error "%s: %s" $data(url) $i
249 | Error $s 404
250 | }
251 | }
252 |
253 | Done $s
254 | }
255 |
256 | proc uhttpd::ContentType {path} {
257 |
258 | # @c Convert the file suffix into a mime type.
259 |
260 | variable MimeTypes
261 |
262 | set type "text/plain"
263 | catch {set type $MimeTypes([file extension $path])}
264 |
265 | return $type
266 | }
267 |
268 | proc uhttpd::Error {s code} {
269 |
270 | # @c Emit error page.
271 |
272 | variable Httpd
273 | variable HttpCodes
274 | variable ErrorPage
275 |
276 | upvar \#0 [namespace current]::Httpd$s data
277 |
278 | append data(url) ""
279 | set msg \
280 | [format $ErrorPage \
281 | $code \
282 | $HttpCodes($code) \
283 | $HttpCodes($code) \
284 | $data(url) \
285 | $Httpd(-name) \
286 | $Httpd(-vers) \
287 | $Httpd(host) \
288 | $Httpd(port) \
289 | ]
290 | if {[catch {
291 | puts $s "HTTP/1.0 $code $HttpCodes($code)"
292 | puts $s "Date: [Date]"
293 | puts $s "Content-Length: [string length $msg]"
294 | puts $s ""
295 | puts $s $msg
296 | } err]} {
297 | Log error "client closed connection prematurely: %s" $err
298 | }
299 | }
300 |
301 | proc uhttpd::Date {{seconds 0}} {
302 |
303 | # @c Generate a date string in HTTP format.
304 |
305 | if {$seconds == 0} {
306 | set seconds [clock seconds]
307 | }
308 | clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1
309 | }
310 |
311 | proc uhttpd::Log {reason format args} {
312 |
313 | # @c Log an httpd transaction.
314 |
315 | set messg [eval format [list $format] $args]
316 | set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"]
317 |
318 | puts stderr "\[$stamp\] $reason: $messg"
319 | }
320 |
321 | proc uhttpd::Url2File {url} {
322 |
323 | # @c Convert a url into a pathname (this is probably not right)
324 |
325 | variable Httpd
326 |
327 | lappend pathlist $Httpd(-root)
328 | set level 0
329 |
330 | foreach part [split $url /] {
331 | set part [CgiMap $part]
332 | if [regexp {[:/]} $part] {
333 | return ""
334 | }
335 | switch -- $part {
336 | "." { }
337 | ".." {incr level -1}
338 | default {incr level}
339 | }
340 | if {$level <= 0} {
341 | return ""
342 | }
343 | lappend pathlist $part
344 | }
345 |
346 | set file [eval file join $pathlist]
347 |
348 | if {[file isdirectory $file]} {
349 | return [file join $file $Httpd(-index)]
350 | } else {
351 | return $file
352 | }
353 | }
354 |
355 | proc uhttpd::CgiMap {data} {
356 |
357 | # @c Decode url-encoded strings
358 |
359 | regsub -all {\+} $data { } data
360 | regsub -all {([][$\\])} $data {\\\1} data
361 | regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
362 |
363 | return [subst $data]
364 | }
365 |
366 | proc uhttpd::QueryMap {query} {
367 |
368 | # @c Decode url-encoded query into key/value pairs
369 |
370 | set res [list]
371 |
372 | regsub -all {[&=]} $query { } query
373 | regsub -all { } $query { {} } query; # Othewise we lose empty values
374 |
375 | foreach {key val} $query {
376 | lappend res [CgiMap $key] [CgiMap $val]
377 | }
378 | return $res
379 | }
380 |
381 | proc /monitor {array} {
382 |
383 | upvar $array data ; # Holds the socket to remote client
384 |
385 | #
386 | # Emit headers
387 | #
388 |
389 | puts $data(sock) "HTTP/1.0 200 OK"
390 | puts $data(sock) "Date: [uhttpd::Date]"
391 | puts $data(sock) "Content-Type: text/html"
392 | puts $data(sock) ""
393 |
394 | #
395 | # Emit body
396 | #
397 |
398 | puts $data(sock) [subst {
399 |
400 |
401 | [clock format [clock seconds]]
402 | }]
403 |
404 | after 1 ; # Simulate blocking call
405 |
406 | puts $data(sock) [subst {
407 |
408 |
409 | }]
410 | }
411 |
412 | # EOF $RCSfile$
413 | # Emacs Setup Variables
414 | # Local Variables:
415 | # mode: Tcl
416 | # indent-tabs-mode: nil
417 | # tcl-basic-offset: 4
418 | # End:
419 |
420 |
--------------------------------------------------------------------------------
/doc/html/tpool.html:
--------------------------------------------------------------------------------
1 |
3 |
4 | tpool - Tcl Threading
5 |
6 |
8 |
10 |
11 |
12 | tpool(n) 2.6 "Tcl Threading"
13 |
14 |
15 |
tpool -
16 | Part of the Tcl threading extension implementing pools of worker threads.
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 | TABLE OF CONTENTS
25 | SYNOPSIS
26 | DESCRIPTION
27 | COMMANDS
28 | DISCUSSION
29 | SEE ALSO
30 | KEYWORDS
31 |
32 |
33 | package require Tcl 8.4
34 | package require Thread ?2.6?
35 |
44 |
45 |
46 | This package creates and manages pools of worker threads. It allows you
47 | to post jobs to worker threads and wait for their completion. The
48 | threadpool implementation is Tcl event-loop aware. That means that any
49 | time a caller is forced to wait for an event (job being completed or
50 | a worker thread becoming idle or initialized), the implementation will
51 | enter the event loop and allow for servicing of other pending file or
52 | timer (or any other supported) events.
53 |
54 |
55 |
56 |
57 |
58 |
59 | - tpool::create ?options?
-
60 |
61 |
62 | This command creates new threadpool. It accepts several options as
63 | key-value pairs. Options are used to tune some threadpool parameters.
64 | The command returns the ID of the newly created threadpool.
65 |
66 | Following options are supported:
67 |
68 |
69 |
70 |
71 | - -minworkers number
-
72 | Minimum number of worker threads needed for this threadpool instance.
73 | During threadpool creation, the implementation will create somany
74 | worker threads upfront and will keep at least number of them alive
75 | during the lifetime of the threadpool instance.
76 | Default value of this parameter is 0 (zero). which means that a newly
77 | threadpool will have no worker threads initialy. All worker threads
78 | will be started on demand by callers running tpool::post command
79 | and posting jobs to the job queue.
80 |
81 |
82 | - -maxworkers number
-
83 | Maximum number of worker threads allowed for this threadpool instance.
84 | If a new job is pending and there are no idle worker threads available,
85 | the implementation will try to create new worker thread. If the number
86 | of available worker threads is lower than the given number,
87 | new worker thread will start. The caller will automatically enter the
88 | event loop and wait until the worker thread has initialized. If. however,
89 | the number of available worker threads is equal to the given number,
90 | the caller will enter the event loop and wait for the first worker thread
91 | to get idle, thus ready to run the job.
92 | Default value of this parameter is 4 (four), which means that the
93 | threadpool instance will allow maximum of 4 worker threads running jobs
94 | or being idle waiting for new jobs to get posted to the job queue.
95 |
96 |
97 |
98 | - -idletime seconds
-
99 | Time in seconds an idle worker thread waits for the job to get posted
100 | to the job queue. If no job arrives during this interval and the time
101 | expires, the worker thread will check the number of currently available
102 | worker threads and if the number is higher than the number set by the
103 | minthreads option, it will exit.
104 | If an exitscript has been defined, the exiting worker thread
105 | will first run the script and then exit. Errors from the exit script,
106 | if any, are ignored.
107 |
108 | The idle worker thread is not servicing the event loop. If you, however,
109 | put the worker thread into the event loop, by evaluating the
110 | vwait or other related Tcl commands, the worker thread
111 | will not be in the idle state, hence the idle timer will not be
112 | taken into account.
113 | Default value for this option is unspecified, hence, the Tcl interpreter
114 | of the worker thread will contain just the initial set of Tcl commands.
115 |
116 |
117 | - -initcmd script
-
118 |
119 | Sets a Tcl script used to initialize new worker thread. This is usually
120 | used to load packages and commands in the worker, set default variables,
121 | create namespaces, and such. If the passed script runs into a Tcl error,
122 | the worker will not be created and the initiating command (either the
123 | tpool::create or tpool::post) will throw error.
124 | Default value for this option is unspecified, hence, the Tcl interpreter of
125 | the worker thread will contain just the initial set of Tcl commands.
126 |
127 |
128 | - -exitcmd script
-
129 |
130 | Sets a Tcl script run when the idle worker thread exits. This is normaly
131 | used to cleanup the state of the worker thread, release reserved resources,
132 | cleanup memory and such.
133 | Default value for this option is unspecified, thus no Tcl script will run
134 | on the worker thread exit.
135 |
136 |
137 |
138 |
139 |
140 | - tpool::names
-
141 |
142 |
143 | This command returns a list of IDs of threadpools created with the
144 | tpool::create command. If no threadpools were found, the
145 | command will return empty list.
146 |
147 |
148 | - tpool::post ?-detached? ?-nowait? tpool script
-
149 |
150 |
151 | This command sends a script to the target tpool threadpool
152 | for execution. The script will be executed in the first available idle
153 | worker thread. If there are no idle worker threads available, the command
154 | will create new one, enter the event loop and service events until the
155 | newly created thread is initialized. If the current number of worker
156 | threads is equal to the maximum number of worker threads, as defined
157 | during the threadpool creation, the command will enter the event loop and
158 | service events while waiting for one of the worker threads to become idle.
159 | If the optional ?-nowait? argument is given, the command will not wait
160 | for one idle worker. It will just place the job in the pool's job queue
161 | and return immediately.
162 |
163 | The command returns the ID of the posted job. This ID is used for subsequent
164 | tpool::wait, tpool::get and tpool::cancel commands to wait
165 | for and retrieve result of the posted script, or cancel the posted job
166 | respectively. If the optional ?-detached? argument is specified, the
167 | command will post a detached job. A detached job can not be cancelled or
168 | waited upon and is not identified by the job ID.
169 |
170 | If the threadpool tpool is not found in the list of active
171 | thread pools, the command will throw error. The error will also be triggered
172 | if the newly created worker thread fails to initialize.
173 |
174 |
175 | - tpool::wait tpool joblist ?varname?
-
176 |
177 |
178 | This command waits for one or many jobs, whose job IDs are given in the
179 | joblist to get processed by the worker thread(s). If none of the
180 | specified jobs are ready, the command will enter the event loop, service
181 | events and wait for the first job to get ready.
182 |
183 | The command returns the list of completed job IDs. If the optional variable
184 | ?varname? is given, it will be set to the list of jobs in the
185 | joblist which are still pending. If the threadpool tpool
186 | is not found in the list of active thread pools, the command will throw error.
187 |
188 |
189 | - tpool::cancel tpool joblist ?varname?
-
190 |
191 |
192 | This command cancels the previously posted jobs given by the joblist
193 | to the pool tpool. Job cancellation succeeds only for job still
194 | waiting to be processed. If the job is already being executed by one of
195 | the worker threads, the job will not be cancelled.
196 | The command returns the list of cancelled job IDs. If the optional variable
197 | ?varname? is given, it will be set to the list of jobs in the
198 | joblist which were not cancelled. If the threadpool tpool
199 | is not found in the list of active thread pools, the command will throw error.
200 |
201 |
202 | - tpool::get tpool job
-
203 |
204 |
205 | This command retrieves the result of the previously posted job.
206 | Only results of jobs waited upon with the tpool::wait command
207 | can be retrieved. If the execution of the script resulted in error,
208 | the command will throw the error and update the errorInfo and
209 | errorCode variables correspondingly. If the pool tpool
210 | is not found in the list of threadpools, the command will throw error.
211 | If the job job is not ready for retrieval, because it is currently
212 | being executed by the worker thread, the command will throw error.
213 |
214 |
215 | - tpool::preserve tpool
-
216 |
217 |
218 | Each call to this command increments the reference counter of the
219 | threadpool tpool by one (1). Command returns the value of the
220 | reference counter after the increment.
221 | By incrementing the reference counter, the caller signalizes that
222 | he/she wishes to use the resource for a longer period of time.
223 |
224 |
225 | - tpool::release tpool
-
226 |
227 |
228 | Each call to this command decrements the reference counter of the
229 | threadpool tpool by one (1).Command returns the value of the
230 | reference counter after the decrement.
231 | When the reference counter reaches zero (0), the threadpool tpool
232 | is marked for termination. You should not reference the threadpool
233 | after the tpool::release command returns zero. The tpool
234 | handle goes out of scope and should not be used any more. Any following
235 | reference to the same threadpool handle will result in Tcl error.
236 |
237 |
238 |
239 |
240 |
241 |
242 |
243 | Threadpool is one of the most common threading paradigm when it comes
244 | to server applications handling a large number of relatively small tasks.
245 | A very simplistic model for building a server application would be to
246 | create a new thread each time a request arrives and service the request
247 | in the new thread. One of the disadvantages of this approach is that
248 | the overhead of creating a new thread for each request is significant;
249 | a server that created a new thread for each request would spend more time
250 | and consume more system resources in creating and destroying threads than
251 | in processing actual user requests. In addition to the overhead of
252 | creating and destroying threads, active threads consume system resources.
253 | Creating too many threads can cause the system to run out of memory or
254 | trash due to excessive memory consumption.
255 |
256 | A thread pool offers a solution to both the problem of thread life-cycle
257 | overhead and the problem of resource trashing. By reusing threads for
258 | multiple tasks, the thread-creation overhead is spread over many tasks.
259 | As a bonus, because the thread already exists when a request arrives,
260 | the delay introduced by thread creation is eliminated. Thus, the request
261 | can be serviced immediately. Furthermore, by properly tuning the number
262 | of threads in the thread pool, resource thrashing may also be eliminated
263 | by forcing any request to wait until a thread is available to process it.
264 |
265 |
266 |
267 |
268 |
269 |
270 |
271 | thread, tsv, ttrace
272 |
273 |
274 | thread, threadpool
275 |
276 |
277 |
--------------------------------------------------------------------------------
/doc/tsv.man:
--------------------------------------------------------------------------------
1 | [comment {-*- tcl -*- doctools manpage}]
2 | [manpage_begin tsv n 2.6]
3 | [moddesc {Tcl Threading}]
4 | [titledesc {Part of the Tcl threading extension allowing script level manipulation of data shared between threads.}]
5 | [require Tcl 8.4]
6 | [require Thread [opt 2.6]]
7 |
8 | [description]
9 | This section describes commands implementing thread shared variables.
10 | A thread shared variable is very similar to a Tcl array but in
11 | contrast to a Tcl array it is created in shared memory and can
12 | be accessed from many threads at the same time. Important feature of
13 | thread shared variable is that each access to the variable is internaly
14 | protected by a mutex so script programmer does not have to take care
15 | about locking the variable himself.
16 | [para]
17 | Thread shared variables are not bound to any thread explicitly. That
18 | means that when a thread which created any of thread shared variables
19 | exits, the variable and associated memory is not unset/reclaimed.
20 | User has to explicitly unset the variable to reclaim the memory
21 | consumed by the variable.
22 |
23 | [section {ELEMENT COMMANDS}]
24 |
25 | [list_begin definitions]
26 |
27 | [call [cmd tsv::names] [opt pattern]]
28 |
29 | Returns names of shared variables matching optional [opt pattern]
30 | or all known variables if pattern is ommited.
31 |
32 | [call [cmd tsv::object] [arg varname] [arg element]]
33 |
34 | Creates object accessor command for the [arg element] in the
35 | shared variable [arg varname]. Using this command, one can apply most
36 | of the other shared variable commands as method functions of
37 | the element object command. The object command is automatically
38 | deleted when the element which this command is pointing to is unset.
39 |
40 | [example {
41 | % tsv::set foo bar "A shared string"
42 | % set string [tsv::object foo bar]
43 | % $string append " appended"
44 | => A shared string appended
45 | }]
46 |
47 | [call [cmd tsv::set] [arg varname] [arg element] [opt value]]
48 |
49 | Sets the value of the [arg element] in the shared variable [arg varname]
50 | to [arg value] and returns the value to caller. The [arg value]
51 | may be ommited, in which case the command will return the current
52 | value of the element. If the element cannot be found, error is triggered.
53 |
54 | [call [cmd tsv::get] [arg varname] [arg element] [opt namedvar]]
55 |
56 | Retrieves the value of the [arg element] from the shared variable [arg varname].
57 | If the optional argument [arg namedvar] is given, the value is
58 | stored in the named variable. Return value of the command depends
59 | of the existence of the optional argument [arg namedvar].
60 | If the argument is ommited and the requested element cannot be found
61 | in the shared array, the command triggers error. If, however, the
62 | optional argument is given on the command line, the command returns
63 | true (1) if the element is found or false (0) if the element is not found.
64 |
65 | [call [cmd tsv::unset] [arg varname] [opt element]]
66 |
67 | Unsets the [arg element] from the shared variable [arg varname].
68 | If the optional element is not given, it deletes the variable.
69 |
70 | [call [cmd tsv::exists] [arg varname] [arg element]]
71 |
72 | Checks wether the [arg element] exists in the shared variable [arg varname]
73 | and returns true (1) if it does or false (0) if it doesn't.
74 |
75 | [call [cmd tsv::pop] [arg varname] [arg element]]
76 |
77 | Returns value of the [arg element] in the shared variable [arg varname]
78 | and unsets the element, all in one atomic operation.
79 |
80 | [call [cmd tsv::move] [arg varname] [arg oldname] [arg newname]]
81 |
82 | Renames the element [arg oldname] to the [arg newname] in the
83 | shared variable [arg varname]. This effectively performs an get/unset/set
84 | sequence of operations but all in one atomic step.
85 |
86 | [call [cmd tsv::incr] [arg varname] [arg element] [opt count]]
87 |
88 | Similar to standard Tcl [cmd incr] command but increments the value
89 | of the [arg element] in shared variaboe [arg varname] instead of
90 | the Tcl variable.
91 |
92 | [call [cmd tsv::append] [arg varname] [arg element] [arg value] [opt {value ...}]]
93 |
94 | Similar to standard Tcl [cmd append] command but appends one or more
95 | values to the [arg element] in shared variable [arg varname] instead of the
96 | Tcl variable.
97 |
98 | [call [cmd tsv::lock] [arg varname] [arg arg] [opt {arg ...}]]
99 |
100 | This command concatenates passed arguments and evaluates the
101 | resulting script under the internal mutex protection. During the
102 | script evaluation, the entire shared variable is locked. For shared
103 | variable commands within the script, internal locking is disabled
104 | so no deadlock can occur. It is also allowed to unset the shared
105 | variable from within the script. The shared variable is automatically
106 | created if it did not exists at the time of the first lock operation.
107 |
108 | [example {
109 | % tsv::lock foo {
110 | tsv::lappend foo bar 1
111 | tsv::lappend foo bar 2
112 | puts stderr [tsv::set foo bar]
113 | tsv::unset foo
114 | }
115 | }]
116 |
117 | [list_end]
118 |
119 | [section {LIST COMMANDS}]
120 |
121 | Those command are similar to the equivalently named Tcl command. The difference
122 | is that they operate on elements of shared arrays.
123 |
124 | [list_begin definitions]
125 |
126 | [call [cmd tsv::lappend] [arg varname] [arg element] [arg value] [opt {value ...}]]
127 |
128 | Similar to standard Tcl [cmd lappend] command but appends one
129 | or more values to the [arg element] in shared variable [arg varname]
130 | instead of the Tcl variable.
131 |
132 | [call [cmd tsv::linsert] [arg varname] [arg element] [arg index] [arg value] [opt {value ...}]]
133 |
134 | Similar to standard Tcl [cmd linsert] command but inserts one
135 | or more values at the [arg index] list position in the
136 | [arg element] in the shared variable [arg varname] instead of the Tcl variable.
137 |
138 | [call [cmd tsv::lreplace] [arg varname] [arg element] [arg first] [arg last] [opt {value ...}]]
139 |
140 | Similar to standard Tcl [cmd lreplace] command but replaces one
141 | or more values between the [arg first] and [arg last] position
142 | in the [arg element] of the shared variable [arg varname] instead of
143 | the Tcl variable.
144 |
145 | [call [cmd tsv::llength] [arg varname] [arg element]]
146 |
147 | Similar to standard Tcl [cmd llength] command but returns length
148 | of the [arg element] in the shared variable [arg varname] instead of the Tcl
149 | variable.
150 |
151 | [call [cmd tsv::lindex] [arg varname] [arg element] [opt index]]
152 |
153 | Similar to standard Tcl [cmd lindex] command but returns the value
154 | at the [arg index] list position of the [arg element] from
155 | the shared variable [arg varname] instead of the Tcl variable.
156 |
157 | [call [cmd tsv::lrange] [arg varname] [arg element] [arg from] [arg to]]
158 |
159 | Similar to standard Tcl [cmd lrange] command but returns values
160 | between [arg from] and [arg to] list positions from the
161 | [arg element] in the shared variable [arg varname] instead of the Tcl variable.
162 |
163 | [call [cmd tsv::lsearch] [arg varname] [arg element] [opt options] [arg pattern]]
164 |
165 | Similar to standard Tcl [cmd lsearch] command but searches the [arg element]
166 | in the shared variable [arg varname] instead of the Tcl variable.
167 |
168 | [call [cmd tsv::lset] [arg varname] [arg element] [arg index] [opt {index ...}] [arg value]]
169 |
170 | Similar to standard Tcl [cmd lset] command but sets the [arg element]
171 | in the shared variable [arg varname] instead of the Tcl variable.
172 |
173 | [call [cmd tsv::lpop] [arg varname] [arg element] [opt index]]
174 |
175 | Similar to the standard Tcl [cmd lindex] command but in addition to
176 | returning, it also splices the value out of the [arg element]
177 | from the shared variable [arg varname] in one atomic operation.
178 | In contrast to the Tcl [cmd lindex] command, this command returns
179 | no value to the caller.
180 |
181 | [call [cmd tsv::lpush] [arg varname] [arg element] [opt index]]
182 |
183 | This command performes the opposite of the [cmd tsv::lpop] command.
184 | As its counterpart, it returns no value to the caller.
185 |
186 | [list_end]
187 |
188 | [section {ARRAY COMMANDS}]
189 |
190 | This command supports most of the options of the standard Tcl
191 | [cmd array] command. In addition to those, it allows binding
192 | a shared variable to some persisten storage databases. Currently
193 | the only persistent option supported is the famous GNU Gdbm
194 | database. This option has to be selected during the package
195 | compilation time. The implementation provides hooks for
196 | defining other persistency layers, if needed.
197 |
198 | [list_begin definitions]
199 |
200 | [call [cmd {tsv::array set}] [arg varname] [arg list]]
201 |
202 | Does the same as standard Tcl [cmd {array set}].
203 |
204 | [call [cmd {tsv::array get}] [arg varname] [opt pattern]]
205 |
206 | Does the same as standard Tcl [cmd {array get}].
207 |
208 | [call [cmd {tsv::array names}] [arg varname] [opt pattern]]
209 |
210 | Does the same as standard Tcl [cmd {array names}].
211 |
212 | [call [cmd {tsv::array size}] [arg varname]]
213 |
214 | Does the same as standard Tcl [cmd {array size}].
215 |
216 | [call [cmd {tsv::array reset}] [arg varname] [arg list]]
217 |
218 | Does the same as standard Tcl [cmd {array set}] but it clears
219 | the [arg varname] and sets new values from the list atomically.
220 |
221 | [call [cmd {tsv::array bind}] [arg varname] [arg handle]]
222 | Binds the [arg varname] to the persistent storage [arg handle].
223 | The format of the [arg handle] is :. For the built-in
224 | GNU Gdbm persistence layer, the format of the handle is "gdbm:"
225 | where is the path to the Gdbm database file.
226 |
227 | [call [cmd {tsv::array unbind}] [arg varname]]
228 | Unbinds the shared [arg array] from its bound persistent storage.
229 |
230 | [call [cmd {tsv::array isbound}] [arg varname]]
231 | Returns true (1) if the shared [arg varname] is bound to some
232 | persistent storage or zero (0) if not.
233 |
234 |
235 | [list_end]
236 |
237 | [section {KEYED LIST COMMANDS}]
238 |
239 | Keyed list commands are borrowed from the TclX package. Keyed lists provide
240 | a structured data type built upon standard Tcl lists. This is a functionality
241 | similar to structs in the C programming language.
242 | [para]
243 | A keyed list is a list in which each element contains a key and value
244 | pair. These element pairs are stored as lists themselves, where the key
245 | is the first element of the list, and the value is the second. The
246 | key-value pairs are referred to as fields. This is an example of a
247 | keyed list:
248 |
249 | [example {
250 | {{NAME {Frank Zappa}} {JOB {musician and composer}}}
251 | }]
252 |
253 | Fields may contain subfields; `.' is the separator character. Subfields
254 | are actually fields where the value is another keyed list. Thus the
255 | following list has the top level fields ID and NAME, and subfields
256 | NAME.FIRST and NAME.LAST:
257 |
258 | [example {
259 | {ID 106} {NAME {{FIRST Frank} {LAST Zappa}}}
260 | }]
261 |
262 | There is no limit to the recursive depth of subfields,
263 | allowing one to build complex data structures. Keyed lists are constructed
264 | and accessed via a number of commands. All keyed list management
265 | commands take the name of the variable containing the keyed list as an
266 | argument (i.e. passed by reference), rather than passing the list directly.
267 |
268 | [list_begin definitions]
269 |
270 | [call [cmd tsv::keyldel] [arg varname] [arg keylist] [arg key]]
271 |
272 | Delete the field specified by [arg key] from the keyed list [arg keylist]
273 | in the shared variable [arg varname].
274 | This removes both the key and the value from the keyed list.
275 |
276 | [call [cmd tsv::keylget] [arg varname] [arg keylist] [arg key] [opt retvar]]
277 |
278 | Return the value associated with [arg key] from the keyed list [arg keylist]
279 | in the shared variable [arg varname].
280 | If the optional [arg retvar] is not specified, then the value will be
281 | returned as the result of the command. In this case, if key is not found
282 | in the list, an error will result.
283 | [para]
284 | If [arg retvar] is specified and [arg key] is in the list, then the value
285 | is returned in the variable [arg retvar] and the command returns 1 if the
286 | key was present within the list. If [arg key] isn't in the list, the
287 | command will return 0, and [arg retvar] will be left unchanged. If {} is
288 | specified for [arg retvar], the value is not returned, allowing the Tcl
289 | programmer to determine if a [arg key] is present in a keyed list without
290 | setting a variable as a side-effect.
291 |
292 | [call [cmd tsv::keylkeys] [arg varname] [arg keylist] [opt key]]
293 | Return the a list of the keys in the keyed list [arg keylist] in the
294 | shared variable [arg varname]. If [arg key] is specified, then it is
295 | the name of a key field who's subfield keys are to be retrieved.
296 |
297 |
298 | [call [cmd tsv::keylset] [arg varname] [arg keylist] [arg key] [arg value] [opt {key value..}]]
299 | Set the value associated with [arg key], in the keyed list [arg keylist]
300 | to [arg value]. If the [arg keylist] does not exists, it is created.
301 | If [arg key] is not currently in the list, it will be added. If it already
302 | exists, [arg value] replaces the existing value. Multiple keywords and
303 | values may be specified, if desired.
304 |
305 | [list_end]
306 |
307 |
308 | [section DISCUSSION]
309 | The current implementation of thread shared variables allows for easy and
310 | convenient access to data shared between different threads.
311 | Internally, the data is stored in Tcl objects and all package commands
312 | operate on internal data representation, thus minimizing shimmering and
313 | improving performance. Special care has been taken to assure that all
314 | object data is properly locked and deep-copied when moving objects between
315 | threads.
316 | [para]
317 | Due to the internal design of the Tcl core, there is no provision of full
318 | integration of shared variables within the Tcl syntax, unfortunately. All
319 | access to shared data must be performed with the supplied package commands.
320 | Also, variable traces are not supported. But even so, benefits of easy,
321 | simple and safe shared data manipulation outweights imposed limitations.
322 |
323 | [section CREDITS]
324 | Thread shared variables are inspired by the nsv interface found in
325 | AOLserver, a highly scalable Web server from America Online.
326 |
327 | [see_also tpool ttrace thread]
328 |
329 | [keywords threads synchronization locking {thread shared data}]
330 |
331 | [manpage_end]
332 |
--------------------------------------------------------------------------------
/doc/html/ttrace.html:
--------------------------------------------------------------------------------
1 |
3 |
4 | ttrace - Tcl Threading
5 |
6 |
8 |
10 |
11 |
12 | ttrace(n) 2.6 "Tcl Threading"
13 |
14 |
15 |
ttrace - Trace-based interpreter initialization
16 |
17 |
18 |
19 |
20 |
21 |
22 | TABLE OF CONTENTS
23 | SYNOPSIS
24 | DESCRIPTION
25 | USER COMMANDS
26 | CALLBACK COMMANDS
27 | DISCUSSION
28 | SEE ALSO
29 | KEYWORDS
30 |
31 |
32 | package require Tcl 8.4
33 | package require Thread ?2.6?
34 |
52 |
53 |
54 | This package creates a framework for on-demand replication of the
55 | interpreter state accross threads in an multithreading application.
56 | It relies on the mechanics of Tcl command tracing and the Tcl
57 | unknown command and mechanism.
58 |
59 | The package requires Tcl threading extension but can be alternatively
60 | used stand-alone within the AOLserver, a scalable webserver from
61 | America Online.
62 |
63 | In a nutshell, a short sample illustrating the usage of the ttrace
64 | with the Tcl threading extension:
65 |
66 |
| |
67 |
68 | % package require Ttrace
69 | 2.6.5
70 |
71 | % set t1 [thread::create {package require Ttrace; thread::wait}]
72 | tid0x1802800
73 |
74 | % ttrace::eval {proc test args {return test-[thread::id]}}
75 | % thread::send $t1 test
76 | test-tid0x1802800
77 |
78 | % set t2 [thread::create {package require Ttrace; thread::wait}]
79 | tid0x1804000
80 |
81 | % thread::send $t2 test
82 | test-tid0x1804000
83 |
84 | |
85 |
86 | As seen from above, the ttrace::eval and ttrace::update
87 | commands are used to create a thread-wide definition of a simple
88 | Tcl procedure and replicate that definition to all, already existing
89 | or later created, threads.
90 |
91 |
92 |
93 | This section describes user-level commands. Those commands can be
94 | used by script writers to control the execution of the tracing
95 | framework.
96 |
97 |
98 |
99 | - ttrace::eval arg ?arg ...?
-
100 |
101 |
102 | This command concatenates given arguments and evaluates the resulting
103 | Tcl command with trace framework enabled. If the command execution
104 | was ok, it takes necessary steps to automatically propagate the
105 | trace epoch change to all threads in the application.
106 | For AOLserver, only newly created threads actually receive the
107 | epoch change. For the Tcl threading extension, all threads created by
108 | the extension are automatically updated. If the command execution
109 | resulted in Tcl error, no state propagation takes place.
110 |
111 | This is the most important user-level command of the package as
112 | it wraps most of the commands described below. This greatly
113 | simplifies things, because user need to learn just this (one)
114 | command in order to effectively use the package. Other commands,
115 | as desribed below, are included mostly for the sake of completeness.
116 |
117 |
118 | - ttrace::enable
-
119 |
120 |
121 | Activates all registered callbacks in the framework
122 | and starts a new trace epoch. The trace epoch encapsulates all
123 | changes done to the interpreter during the time traces are activated.
124 |
125 |
126 | - ttrace::disable
-
127 |
128 |
129 | Deactivates all registered callbacks in the framework
130 | and closes the current trace epoch.
131 |
132 |
133 | - ttrace::cleanup
-
134 |
135 |
136 | Used to clean-up all on-demand loaded resources in the interpreter.
137 | It effectively brings Tcl interpreter to its pristine state.
138 |
139 |
140 | - ttrace::update ?epoch?
-
141 |
142 |
143 | Used to refresh the state of the interpreter to match the optional
144 | trace ?epoch?. If the optional ?epoch? is not given, it takes
145 | the most recent trace epoch.
146 |
147 |
148 | - ttrace::getscript
-
149 |
150 |
151 | Returns a synthetized Tcl script which may be sourced in any interpreter.
152 | This script sets the stage for the Tcl unknown command so it can
153 | load traced resources from the in-memory database. Normally, this command
154 | is automatically invoked by other higher-level commands like
155 | ttrace::eval and ttrace::update.
156 |
157 |
158 |
159 |
160 |
161 | A word upfront: the package already includes callbacks for tracing
162 | following Tcl commands: proc, namespace, variable,
163 | load, and rename. Additionaly, a set of callbacks for
164 | tracing resources (object, clasess) for the XOTcl v1.3.8+, an
165 | OO-extension to Tcl, is also provided.
166 | This gives a solid base for solving most of the real-life needs and
167 | serves as an example for people wanting to customize the package
168 | to cover their specific needs.
169 |
170 | Below, you can find commands for registering callbacks in the
171 | framework and for writing callback scripts. These callbacks are
172 | invoked by the framework in order to gather interpreter state
173 | changes, build in-memory database, perform custom-cleanups and
174 | various other tasks.
175 |
176 |
177 |
178 |
179 | - ttrace::atenable cmd arglist body
-
180 |
181 |
182 | Registers Tcl callback to be activated at ttrace::enable.
183 | Registered callbacks are activated on FIFO basis. The callback
184 | definition includes the name of the callback, cmd, a list
185 | of callback arguments, arglist and the body of the
186 | callback. Effectively, this actually resembles the call interface
187 | of the standard Tcl proc command.
188 |
189 |
190 |
191 | - ttrace::atdisable cmd arglist body
-
192 |
193 |
194 | Registers Tcl callback to be activated at ttrace::disable.
195 | Registered callbacks are activated on FIFO basis. The callback
196 | definition includes the name of the callback, cmd, a list
197 | of callback arguments, arglist and the body of the
198 | callback. Effectively, this actually resembles the call interface
199 | of the standard Tcl proc command.
200 |
201 |
202 |
203 | - ttrace::addtrace cmd arglist body
-
204 |
205 |
206 | Registers Tcl callback to be activated for tracing the Tcl
207 | cmd command. The callback definition includes the name of
208 | the Tcl command to trace, cmd, a list of callback arguments,
209 | arglist and the body of the callback. Effectively,
210 | this actually resembles the call interface of the standard Tcl
211 | proc command.
212 |
213 |
214 |
215 | - ttrace::addscript name body
-
216 |
217 |
218 | Registers Tcl callback to be activated for building a Tcl
219 | script to be passed to other interpreters. This script is
220 | used to set the stage for the Tcl unknown command.
221 | Registered callbacks are activated on FIFO basis.
222 | The callback definition includes the name of the callback,
223 | name and the body of the callback.
224 |
225 |
226 | - ttrace::addresolver cmd arglist body
-
227 |
228 |
229 | Registers Tcl callback to be activated by the overloaded Tcl
230 | unknown command.
231 | Registered callbacks are activated on FIFO basis.
232 | This callback is used to resolve the resource and load the
233 | resource in the current interpreter.
234 |
235 |
236 | - ttrace::addcleanup body
-
237 |
238 |
239 | Registers Tcl callback to be activated by the trace::cleanup.
240 | Registered callbacks are activated on FIFO basis.
241 |
242 |
243 | - ttrace::addentry cmd var val
-
244 |
245 |
246 | Adds one entry to the named in-memory database.
247 |
248 |
249 | - ttrace::getentry cmd var
-
250 |
251 |
252 | Returns the value of the entry from the named in-memory database.
253 |
254 |
255 | - ttrace::getentries cmd ?pattern?
-
256 |
257 |
258 | Returns names of all entries from the named in-memory database.
259 |
260 |
261 | - ttrace::delentry cmd
-
262 |
263 |
264 | Deletes an entry from the named in-memory database.
265 |
266 |
267 | - ttrace::preload cmd
-
268 |
269 |
270 | Registers the Tcl command to be loaded in the interpreter.
271 | Commands registered this way will always be the part of
272 | the interpreter and not be on-demand loaded by the Tcl
273 | unknown command.
274 |
275 |
276 |
277 |
278 |
279 | Common introspective state-replication approaches use a custom Tcl
280 | script to introspect the running interpreter and synthesize another
281 | Tcl script to replicate this state in some other interpreter.
282 | This package, on the contrary, uses Tcl command traces. Command
283 | traces are registered on selected Tcl commands, like proc,
284 | namespace, load and other standard (and/or user-defined)
285 | Tcl commands. When activated, those traces build an in-memory
286 | database of created resources. This database is used as a resource
287 | repository for the (overloaded) Tcl unknown command which
288 | creates the requested resource in the interpreter on demand.
289 | This way, users can update just one interpreter (master) in one
290 | thread and replicate that interpreter state (or part of it) to other
291 | threads/interpreters in the process.
292 |
293 | Immediate benefit of such approach is the much smaller memory footprint
294 | of the application and much faster thread creation. By not actually
295 | loading all necessary procedures (and other resources) in every thread
296 | at the thread initialization time, but by deffering this to the time the
297 | resource is actually referenced, significant improvements in both
298 | memory consumption and thread initialization time can be achieved. Some
299 | tests have shown that memory footprint of an multithreading Tcl application
300 | went down more than three times and thread startup time was reduced for
301 | about 50 times. Note that your mileage may vary.
302 |
303 | Other benefits include much finer control about what (and when) gets
304 | replicated from the master to other Tcl thread/interpreters.
305 |
306 |
307 |
308 |
309 |
310 |
311 |
312 | thread, tpool, tsv
313 |
314 |
315 | command tracing, introspection
316 |
317 |
318 |
--------------------------------------------------------------------------------
/doc/man/ttrace.n:
--------------------------------------------------------------------------------
1 | '\"
2 | '\" Generated from file '' by tcllib/doctools with format 'nroff'
3 | '\"
4 | '\" -*- tcl -*- doctools manpage
5 | '\" The definitions below are for supplemental macros used in Tcl/Tk
6 | '\" manual entries.
7 | '\"
8 | '\" .AP type name in/out ?indent?
9 | '\" Start paragraph describing an argument to a library procedure.
10 | '\" type is type of argument (int, etc.), in/out is either "in", "out",
11 | '\" or "in/out" to describe whether procedure reads or modifies arg,
12 | '\" and indent is equivalent to second arg of .IP (shouldn't ever be
13 | '\" needed; use .AS below instead)
14 | '\"
15 | '\" .AS ?type? ?name?
16 | '\" Give maximum sizes of arguments for setting tab stops. Type and
17 | '\" name are examples of largest possible arguments that will be passed
18 | '\" to .AP later. If args are omitted, default tab stops are used.
19 | '\"
20 | '\" .BS
21 | '\" Start box enclosure. From here until next .BE, everything will be
22 | '\" enclosed in one large box.
23 | '\"
24 | '\" .BE
25 | '\" End of box enclosure.
26 | '\"
27 | '\" .CS
28 | '\" Begin code excerpt.
29 | '\"
30 | '\" .CE
31 | '\" End code excerpt.
32 | '\"
33 | '\" .VS ?version? ?br?
34 | '\" Begin vertical sidebar, for use in marking newly-changed parts
35 | '\" of man pages. The first argument is ignored and used for recording
36 | '\" the version when the .VS was added, so that the sidebars can be
37 | '\" found and removed when they reach a certain age. If another argument
38 | '\" is present, then a line break is forced before starting the sidebar.
39 | '\"
40 | '\" .VE
41 | '\" End of vertical sidebar.
42 | '\"
43 | '\" .DS
44 | '\" Begin an indented unfilled display.
45 | '\"
46 | '\" .DE
47 | '\" End of indented unfilled display.
48 | '\"
49 | '\" .SO
50 | '\" Start of list of standard options for a Tk widget. The
51 | '\" options follow on successive lines, in four columns separated
52 | '\" by tabs.
53 | '\"
54 | '\" .SE
55 | '\" End of list of standard options for a Tk widget.
56 | '\"
57 | '\" .OP cmdName dbName dbClass
58 | '\" Start of description of a specific option. cmdName gives the
59 | '\" option's name as specified in the class command, dbName gives
60 | '\" the option's name in the option database, and dbClass gives
61 | '\" the option's class in the option database.
62 | '\"
63 | '\" .UL arg1 arg2
64 | '\" Print arg1 underlined, then print arg2 normally.
65 | '\"
66 | '\" RCS: @(#) $Id$
67 | '\"
68 | '\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
69 | .if t .wh -1.3i ^B
70 | .nr ^l \n(.l
71 | .ad b
72 | '\" # Start an argument description
73 | .de AP
74 | .ie !"\\$4"" .TP \\$4
75 | .el \{\
76 | . ie !"\\$2"" .TP \\n()Cu
77 | . el .TP 15
78 | .\}
79 | .ta \\n()Au \\n()Bu
80 | .ie !"\\$3"" \{\
81 | \&\\$1 \\fI\\$2\\fP (\\$3)
82 | .\".b
83 | .\}
84 | .el \{\
85 | .br
86 | .ie !"\\$2"" \{\
87 | \&\\$1 \\fI\\$2\\fP
88 | .\}
89 | .el \{\
90 | \&\\fI\\$1\\fP
91 | .\}
92 | .\}
93 | ..
94 | '\" # define tabbing values for .AP
95 | .de AS
96 | .nr )A 10n
97 | .if !"\\$1"" .nr )A \\w'\\$1'u+3n
98 | .nr )B \\n()Au+15n
99 | .\"
100 | .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
101 | .nr )C \\n()Bu+\\w'(in/out)'u+2n
102 | ..
103 | .AS Tcl_Interp Tcl_CreateInterp in/out
104 | '\" # BS - start boxed text
105 | '\" # ^y = starting y location
106 | '\" # ^b = 1
107 | .de BS
108 | .br
109 | .mk ^y
110 | .nr ^b 1u
111 | .if n .nf
112 | .if n .ti 0
113 | .if n \l'\\n(.lu\(ul'
114 | .if n .fi
115 | ..
116 | '\" # BE - end boxed text (draw box now)
117 | .de BE
118 | .nf
119 | .ti 0
120 | .mk ^t
121 | .ie n \l'\\n(^lu\(ul'
122 | .el \{\
123 | .\" Draw four-sided box normally, but don't draw top of
124 | .\" box if the box started on an earlier page.
125 | .ie !\\n(^b-1 \{\
126 | \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
127 | .\}
128 | .el \}\
129 | \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
130 | .\}
131 | .\}
132 | .fi
133 | .br
134 | .nr ^b 0
135 | ..
136 | '\" # VS - start vertical sidebar
137 | '\" # ^Y = starting y location
138 | '\" # ^v = 1 (for troff; for nroff this doesn't matter)
139 | .de VS
140 | .if !"\\$2"" .br
141 | .mk ^Y
142 | .ie n 'mc \s12\(br\s0
143 | .el .nr ^v 1u
144 | ..
145 | '\" # VE - end of vertical sidebar
146 | .de VE
147 | .ie n 'mc
148 | .el \{\
149 | .ev 2
150 | .nf
151 | .ti 0
152 | .mk ^t
153 | \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
154 | .sp -1
155 | .fi
156 | .ev
157 | .\}
158 | .nr ^v 0
159 | ..
160 | '\" # Special macro to handle page bottom: finish off current
161 | '\" # box/sidebar if in box/sidebar mode, then invoked standard
162 | '\" # page bottom macro.
163 | .de ^B
164 | .ev 2
165 | 'ti 0
166 | 'nf
167 | .mk ^t
168 | .if \\n(^b \{\
169 | .\" Draw three-sided box if this is the box's first page,
170 | .\" draw two sides but no top otherwise.
171 | .ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
172 | .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
173 | .\}
174 | .if \\n(^v \{\
175 | .nr ^x \\n(^tu+1v-\\n(^Yu
176 | \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
177 | .\}
178 | .bp
179 | 'fi
180 | .ev
181 | .if \\n(^b \{\
182 | .mk ^y
183 | .nr ^b 2
184 | .\}
185 | .if \\n(^v \{\
186 | .mk ^Y
187 | .\}
188 | ..
189 | '\" # DS - begin display
190 | .de DS
191 | .RS
192 | .nf
193 | .sp
194 | ..
195 | '\" # DE - end display
196 | .de DE
197 | .fi
198 | .RE
199 | .sp
200 | ..
201 | '\" # SO - start of list of standard options
202 | .de SO
203 | .SH "STANDARD OPTIONS"
204 | .LP
205 | .nf
206 | .ta 5.5c 11c
207 | .ft B
208 | ..
209 | '\" # SE - end of list of standard options
210 | .de SE
211 | .fi
212 | .ft R
213 | .LP
214 | See the \\fBoptions\\fR manual entry for details on the standard options.
215 | ..
216 | '\" # OP - start of full description for a single option
217 | .de OP
218 | .LP
219 | .nf
220 | .ta 4c
221 | Command-Line Name: \\fB\\$1\\fR
222 | Database Name: \\fB\\$2\\fR
223 | Database Class: \\fB\\$3\\fR
224 | .fi
225 | .IP
226 | ..
227 | '\" # CS - begin code excerpt
228 | .de CS
229 | .RS
230 | .nf
231 | .ta .25i .5i .75i 1i
232 | .if t .ft C
233 | ..
234 | '\" # CE - end code excerpt
235 | .de CE
236 | .fi
237 | .if t .ft R
238 | .RE
239 | ..
240 | .de UL
241 | \\$1\l'|0\(ul'\\$2
242 | ..
243 |
244 | .TH "ttrace" n 2.6 "Tcl Threading"
245 | .BS
246 | .SH "NAME"
247 | ttrace \- Trace-based interpreter initialization
248 | .SH "SYNOPSIS"
249 | package require \fBTcl 8.4\fR
250 | .sp
251 | package require \fBThread ?2.6?\fR
252 | .sp
253 | \fBttrace::eval\fR \fIarg\fR ?arg ...?
254 | .sp
255 | \fBttrace::enable\fR
256 | .sp
257 | \fBttrace::disable\fR
258 | .sp
259 | \fBttrace::cleanup\fR
260 | .sp
261 | \fBttrace::update\fR ?epoch?
262 | .sp
263 | \fBttrace::getscript\fR
264 | .sp
265 | \fBttrace::atenable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
266 | .sp
267 | \fBttrace::atdisable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
268 | .sp
269 | \fBttrace::addtrace\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
270 | .sp
271 | \fBttrace::addscript\fR \fIname\fR \fIbody\fR
272 | .sp
273 | \fBttrace::addresolver\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
274 | .sp
275 | \fBttrace::addcleanup\fR \fIbody\fR
276 | .sp
277 | \fBttrace::addentry\fR \fIcmd\fR \fIvar\fR \fIval\fR
278 | .sp
279 | \fBttrace::getentry\fR \fIcmd\fR \fIvar\fR
280 | .sp
281 | \fBttrace::getentries\fR \fIcmd\fR ?pattern?
282 | .sp
283 | \fBttrace::delentry\fR \fIcmd\fR
284 | .sp
285 | \fBttrace::preload\fR \fIcmd\fR
286 | .sp
287 | .BE
288 | .SH "DESCRIPTION"
289 | This package creates a framework for on-demand replication of the
290 | interpreter state accross threads in an multithreading application.
291 | It relies on the mechanics of Tcl command tracing and the Tcl
292 | \fBunknown\fR command and mechanism.
293 | .PP
294 | The package requires Tcl threading extension but can be alternatively
295 | used stand-alone within the AOLserver, a scalable webserver from
296 | America Online.
297 | .PP
298 | In a nutshell, a short sample illustrating the usage of the ttrace
299 | with the Tcl threading extension:
300 | .nf
301 |
302 | % package require Ttrace
303 | 2.6.5
304 |
305 | % set t1 [thread::create {package require Ttrace; thread::wait}]
306 | tid0x1802800
307 |
308 | % ttrace::eval {proc test args {return test-[thread::id]}}
309 | % thread::send $t1 test
310 | test-tid0x1802800
311 |
312 | % set t2 [thread::create {package require Ttrace; thread::wait}]
313 | tid0x1804000
314 |
315 | % thread::send $t2 test
316 | test-tid0x1804000
317 |
318 | .fi
319 | .PP
320 | As seen from above, the \fBttrace::eval\fR and \fBttrace::update\fR
321 | commands are used to create a thread-wide definition of a simple
322 | Tcl procedure and replicate that definition to all, already existing
323 | or later created, threads.
324 | .SH "USER COMMANDS"
325 | This section describes user-level commands. Those commands can be
326 | used by script writers to control the execution of the tracing
327 | framework.
328 | .TP
329 | \fBttrace::eval\fR \fIarg\fR ?arg ...?
330 | This command concatenates given arguments and evaluates the resulting
331 | Tcl command with trace framework enabled. If the command execution
332 | was ok, it takes necessary steps to automatically propagate the
333 | trace epoch change to all threads in the application.
334 | For AOLserver, only newly created threads actually receive the
335 | epoch change. For the Tcl threading extension, all threads created by
336 | the extension are automatically updated. If the command execution
337 | resulted in Tcl error, no state propagation takes place.
338 | .sp
339 | This is the most important user-level command of the package as
340 | it wraps most of the commands described below. This greatly
341 | simplifies things, because user need to learn just this (one)
342 | command in order to effectively use the package. Other commands,
343 | as desribed below, are included mostly for the sake of completeness.
344 | .TP
345 | \fBttrace::enable\fR
346 | Activates all registered callbacks in the framework
347 | and starts a new trace epoch. The trace epoch encapsulates all
348 | changes done to the interpreter during the time traces are activated.
349 | .TP
350 | \fBttrace::disable\fR
351 | Deactivates all registered callbacks in the framework
352 | and closes the current trace epoch.
353 | .TP
354 | \fBttrace::cleanup\fR
355 | Used to clean-up all on-demand loaded resources in the interpreter.
356 | It effectively brings Tcl interpreter to its pristine state.
357 | .TP
358 | \fBttrace::update\fR ?epoch?
359 | Used to refresh the state of the interpreter to match the optional
360 | trace ?epoch?. If the optional ?epoch? is not given, it takes
361 | the most recent trace epoch.
362 | .TP
363 | \fBttrace::getscript\fR
364 | Returns a synthetized Tcl script which may be sourced in any interpreter.
365 | This script sets the stage for the Tcl \fBunknown\fR command so it can
366 | load traced resources from the in-memory database. Normally, this command
367 | is automatically invoked by other higher-level commands like
368 | \fBttrace::eval\fR and \fBttrace::update\fR.
369 | .SH "CALLBACK COMMANDS"
370 | A word upfront: the package already includes callbacks for tracing
371 | following Tcl commands: \fBproc\fR, \fBnamespace\fR, \fBvariable\fR,
372 | \fBload\fR, and \fBrename\fR. Additionaly, a set of callbacks for
373 | tracing resources (object, clasess) for the XOTcl v1.3.8+, an
374 | OO-extension to Tcl, is also provided.
375 | This gives a solid base for solving most of the real-life needs and
376 | serves as an example for people wanting to customize the package
377 | to cover their specific needs.
378 | .PP
379 | Below, you can find commands for registering callbacks in the
380 | framework and for writing callback scripts. These callbacks are
381 | invoked by the framework in order to gather interpreter state
382 | changes, build in-memory database, perform custom-cleanups and
383 | various other tasks.
384 | .TP
385 | \fBttrace::atenable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
386 | Registers Tcl callback to be activated at \fBttrace::enable\fR.
387 | Registered callbacks are activated on FIFO basis. The callback
388 | definition includes the name of the callback, \fIcmd\fR, a list
389 | of callback arguments, \fIarglist\fR and the \fIbody\fR of the
390 | callback. Effectively, this actually resembles the call interface
391 | of the standard Tcl \fBproc\fR command.
392 | .TP
393 | \fBttrace::atdisable\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
394 | Registers Tcl callback to be activated at \fBttrace::disable\fR.
395 | Registered callbacks are activated on FIFO basis. The callback
396 | definition includes the name of the callback, \fIcmd\fR, a list
397 | of callback arguments, \fIarglist\fR and the \fIbody\fR of the
398 | callback. Effectively, this actually resembles the call interface
399 | of the standard Tcl \fBproc\fR command.
400 | .TP
401 | \fBttrace::addtrace\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
402 | Registers Tcl callback to be activated for tracing the Tcl
403 | \fBcmd\fR command. The callback definition includes the name of
404 | the Tcl command to trace, \fIcmd\fR, a list of callback arguments,
405 | \fIarglist\fR and the \fIbody\fR of the callback. Effectively,
406 | this actually resembles the call interface of the standard Tcl
407 | \fBproc\fR command.
408 | .TP
409 | \fBttrace::addscript\fR \fIname\fR \fIbody\fR
410 | Registers Tcl callback to be activated for building a Tcl
411 | script to be passed to other interpreters. This script is
412 | used to set the stage for the Tcl \fBunknown\fR command.
413 | Registered callbacks are activated on FIFO basis.
414 | The callback definition includes the name of the callback,
415 | \fIname\fR and the \fIbody\fR of the callback.
416 | .TP
417 | \fBttrace::addresolver\fR \fIcmd\fR \fIarglist\fR \fIbody\fR
418 | Registers Tcl callback to be activated by the overloaded Tcl
419 | \fBunknown\fR command.
420 | Registered callbacks are activated on FIFO basis.
421 | This callback is used to resolve the resource and load the
422 | resource in the current interpreter.
423 | .TP
424 | \fBttrace::addcleanup\fR \fIbody\fR
425 | Registers Tcl callback to be activated by the \fBtrace::cleanup\fR.
426 | Registered callbacks are activated on FIFO basis.
427 | .TP
428 | \fBttrace::addentry\fR \fIcmd\fR \fIvar\fR \fIval\fR
429 | Adds one entry to the named in-memory database.
430 | .TP
431 | \fBttrace::getentry\fR \fIcmd\fR \fIvar\fR
432 | Returns the value of the entry from the named in-memory database.
433 | .TP
434 | \fBttrace::getentries\fR \fIcmd\fR ?pattern?
435 | Returns names of all entries from the named in-memory database.
436 | .TP
437 | \fBttrace::delentry\fR \fIcmd\fR
438 | Deletes an entry from the named in-memory database.
439 | .TP
440 | \fBttrace::preload\fR \fIcmd\fR
441 | Registers the Tcl command to be loaded in the interpreter.
442 | Commands registered this way will always be the part of
443 | the interpreter and not be on-demand loaded by the Tcl
444 | \fBunknown\fR command.
445 | .SH "DISCUSSION"
446 | Common introspective state-replication approaches use a custom Tcl
447 | script to introspect the running interpreter and synthesize another
448 | Tcl script to replicate this state in some other interpreter.
449 | This package, on the contrary, uses Tcl command traces. Command
450 | traces are registered on selected Tcl commands, like \fBproc\fR,
451 | \fBnamespace\fR, \fBload\fR and other standard (and/or user-defined)
452 | Tcl commands. When activated, those traces build an in-memory
453 | database of created resources. This database is used as a resource
454 | repository for the (overloaded) Tcl \fBunknown\fR command which
455 | creates the requested resource in the interpreter on demand.
456 | This way, users can update just one interpreter (master) in one
457 | thread and replicate that interpreter state (or part of it) to other
458 | threads/interpreters in the process.
459 | .PP
460 | Immediate benefit of such approach is the much smaller memory footprint
461 | of the application and much faster thread creation. By not actually
462 | loading all necessary procedures (and other resources) in every thread
463 | at the thread initialization time, but by deffering this to the time the
464 | resource is actually referenced, significant improvements in both
465 | memory consumption and thread initialization time can be achieved. Some
466 | tests have shown that memory footprint of an multithreading Tcl application
467 | went down more than three times and thread startup time was reduced for
468 | about 50 times. Note that your mileage may vary.
469 | Other benefits include much finer control about what (and when) gets
470 | replicated from the master to other Tcl thread/interpreters.
471 | .SH "SEE ALSO"
472 | thread, tpool, tsv
473 | .SH "KEYWORDS"
474 | command tracing, introspection
475 |
--------------------------------------------------------------------------------
/tcl/tpool/tpool.tcl:
--------------------------------------------------------------------------------
1 | #
2 | # tpool.tcl --
3 | #
4 | # Tcl implementation of a threadpool paradigm in pure Tcl using
5 | # the Tcl threading extension 2.5 (or higher).
6 | #
7 | # This file is for example purposes only. The efficient C-level
8 | # threadpool implementation is already a part of the threading
9 | # extension starting with 2.5 version. Both implementations have
10 | # the same Tcl API so both can be used interchangeably. Goal of
11 | # this implementation is to serve as an example of using the Tcl
12 | # extension to implement some very common threading paradigms.
13 | #
14 | # Beware: with time, as improvements are made to the C-level
15 | # implementation, this Tcl one might lag behind.
16 | # Please consider this code as a working example only.
17 | #
18 | #
19 | #
20 | # Copyright (c) 2002 by Zoran Vasiljevic.
21 | #
22 | # See the file "license.terms" for information on usage and
23 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
24 | #
25 | # -----------------------------------------------------------------------------
26 | # RCS: @(#) $Id$
27 | #
28 |
29 | package require Thread 2.5
30 | set thisScript [info script]
31 |
32 | namespace eval tpool {
33 |
34 | variable afterevent "" ; # Idle timer event for worker threads
35 | variable result ; # Stores result from the worker thread
36 | variable waiter ; # Waits for an idle worker thread
37 | variable jobsdone ; # Accumulates results from worker threads
38 |
39 | #
40 | # Create shared array with a single element.
41 | # It is used for automatic pool handles creation.
42 | #
43 |
44 | set ns [namespace current]
45 | tsv::lock $ns {
46 | if {[tsv::exists $ns count] == 0} {
47 | tsv::set $ns count 0
48 | }
49 | tsv::set $ns count -1
50 | }
51 | variable thisScript [info script]
52 | }
53 |
54 | #
55 | # tpool::create --
56 | #
57 | # Creates instance of a thread pool.
58 | #
59 | # Arguments:
60 | # args Variable number of key/value arguments, as follows:
61 | #
62 | # -minworkers minimum # of worker threads (def:0)
63 | # -maxworkers maximum # of worker threads (def:4)
64 | # -idletime # of sec worker is idle before exiting (def:0 = never)
65 | # -initcmd script used to initialize new worker thread
66 | # -exitcmd script run at worker thread exit
67 | #
68 | # Side Effects:
69 | # Might create many new threads if "-minworkers" option is > 0.
70 | #
71 | # Results:
72 | # The id of the newly created thread pool. This id must be used
73 | # in all other tpool::* commands.
74 | #
75 |
76 | proc tpool::create {args} {
77 |
78 | variable thisScript
79 |
80 | #
81 | # Get next threadpool handle and create the pool array.
82 | #
83 |
84 | set usage "wrong \# args: should be \"[lindex [info level 1] 0]\
85 | ?-minworkers count? ?-maxworkers count?\
86 | ?-initcmd script? ?-exitcmd script?\
87 | ?-idletime seconds?\""
88 |
89 | set ns [namespace current]
90 | set tpid [namespace tail $ns][tsv::incr $ns count]
91 |
92 | tsv::lock $tpid {
93 | tsv::set $tpid name $tpid
94 | }
95 |
96 | #
97 | # Setup default pool data.
98 | #
99 |
100 | tsv::array set $tpid {
101 | thrworkers ""
102 | thrwaiters ""
103 | jobcounter 0
104 | refcounter 0
105 | numworkers 0
106 | -minworkers 0
107 | -maxworkers 4
108 | -idletime 0
109 | -initcmd ""
110 | -exitcmd ""
111 | }
112 |
113 | tsv::set $tpid -initcmd "source $thisScript"
114 |
115 | #
116 | # Override with user-supplied data
117 | #
118 |
119 | if {[llength $args] % 2} {
120 | error $usage
121 | }
122 |
123 | foreach {arg val} $args {
124 | switch -- $arg {
125 | -minworkers -
126 | -maxworkers {tsv::set $tpid $arg $val}
127 | -idletime {tsv::set $tpid $arg [expr {$val*1000}]}
128 | -initcmd {tsv::append $tpid $arg \n $val}
129 | -exitcmd {tsv::append $tpid $arg \n $val}
130 | default {
131 | error $usage
132 | }
133 | }
134 | }
135 |
136 | #
137 | # Start initial (minimum) number of worker threads.
138 | #
139 |
140 | for {set ii 0} {$ii < [tsv::set $tpid -minworkers]} {incr ii} {
141 | Worker $tpid
142 | }
143 |
144 | return $tpid
145 | }
146 |
147 | #
148 | # tpool::names --
149 | #
150 | # Returns list of currently created threadpools
151 | #
152 | # Arguments:
153 | # None.
154 | #
155 | # Side Effects:
156 | # None.
157 | #
158 | # Results
159 | # List of active threadpoool identifiers or empty if none found
160 | #
161 | #
162 |
163 | proc tpool::names {} {
164 | tsv::names [namespace tail [namespace current]]*
165 | }
166 |
167 | #
168 | # tpool::post --
169 | #
170 | # Submits the new job to the thread pool. The caller might pass
171 | # the job in two modes: synchronous and asynchronous.
172 | # For the synchronous mode, the pool implementation will retain
173 | # the result of the passed script until the caller collects it
174 | # using the "thread::get" command.
175 | # For the asynchronous mode, the result of the script is ignored.
176 | #
177 | # Arguments:
178 | # args Variable # of arguments with the following syntax:
179 | # tpool::post ?-detached? tpid script
180 | #
181 | # -detached flag to turn the async operation (ignore result)
182 | # tpid the id of the thread pool
183 | # script script to pass to the worker thread for execution
184 | #
185 | # Side Effects:
186 | # Depends on the passed script.
187 | #
188 | # Results:
189 | # The id of the posted job. This id is used later on to collect
190 | # result of the job and set local variables accordingly.
191 | # For asynchronously posted jobs, the return result is ignored
192 | # and this function returns empty result.
193 | #
194 |
195 | proc tpool::post {args} {
196 |
197 | #
198 | # Parse command arguments.
199 | #
200 |
201 | set ns [namespace current]
202 | set usage "wrong \# args: should be \"[lindex [info level 1] 0]\
203 | ?-detached? tpoolId script\""
204 |
205 | if {[llength $args] == 2} {
206 | set detached 0
207 | set tpid [lindex $args 0]
208 | set cmd [lindex $args 1]
209 | } elseif {[llength $args] == 3} {
210 | if {[lindex $args 0] != "-detached"} {
211 | error $usage
212 | }
213 | set detached 1
214 | set tpid [lindex $args 1]
215 | set cmd [lindex $args 2]
216 | } else {
217 | error $usage
218 | }
219 |
220 | #
221 | # Find idle (or create new) worker thread. This is relatively
222 | # a complex issue, since we must honour the limits about number
223 | # of allowed worker threads imposed to us by the caller.
224 | #
225 |
226 | set tid ""
227 |
228 | while {$tid == ""} {
229 | tsv::lock $tpid {
230 | set tid [tsv::lpop $tpid thrworkers]
231 | if {$tid == "" || [catch {thread::preserve $tid}]} {
232 | set tid ""
233 | tsv::lpush $tpid thrwaiters [thread::id] end
234 | if {[tsv::set $tpid numworkers]<[tsv::set $tpid -maxworkers]} {
235 | Worker $tpid
236 | }
237 | }
238 | }
239 | if {$tid == ""} {
240 | vwait ${ns}::waiter
241 | }
242 | }
243 |
244 | #
245 | # Post the command to the worker thread
246 | #
247 |
248 | if {$detached} {
249 | set j ""
250 | thread::send -async $tid [list ${ns}::Run $tpid 0 $cmd]
251 | } else {
252 | set j [tsv::incr $tpid jobcounter]
253 | thread::send -async $tid [list ${ns}::Run $tpid $j $cmd] ${ns}::result
254 | }
255 |
256 | variable jobsdone
257 | set jobsdone($j) ""
258 |
259 | return $j
260 | }
261 |
262 | #
263 | # tpool::wait --
264 | #
265 | # Waits for jobs sent with "thread::post" to finish.
266 | #
267 | # Arguments:
268 | # tpid Name of the pool shared array.
269 | # jobList List of job id's done.
270 | # jobLeft List of jobs still pending.
271 | #
272 | # Side Effects:
273 | # Might eventually enter the event loop while waiting
274 | # for the job result to arrive from the worker thread.
275 | # It ignores bogus job ids.
276 | #
277 | # Results:
278 | # Result of the job. If the job resulted in error, it sets
279 | # the global errorInfo and errorCode variables accordingly.
280 | #
281 |
282 | proc tpool::wait {tpid jobList {jobLeft ""}} {
283 |
284 | variable result
285 | variable jobsdone
286 |
287 | if {$jobLeft != ""} {
288 | upvar $jobLeft jobleft
289 | }
290 |
291 | set retlist ""
292 | set jobleft ""
293 |
294 | foreach j $jobList {
295 | if {[info exists jobsdone($j)] == 0} {
296 | continue ; # Ignore (skip) bogus job ids
297 | }
298 | if {$jobsdone($j) != ""} {
299 | lappend retlist $j
300 | } else {
301 | lappend jobleft $j
302 | }
303 | }
304 | if {[llength $retlist] == 0 && [llength $jobList]} {
305 | #
306 | # No jobs found; wait for the first one to get ready.
307 | #
308 | set jobleft $jobList
309 | while {1} {
310 | vwait [namespace current]::result
311 | set doneid [lindex $result 0]
312 | set jobsdone($doneid) $result
313 | if {[lsearch $jobList $doneid] >= 0} {
314 | lappend retlist $doneid
315 | set x [lsearch $jobleft $doneid]
316 | set jobleft [lreplace $jobleft $x $x]
317 | break
318 | }
319 | }
320 | }
321 |
322 | return $retlist
323 | }
324 |
325 | #
326 | # tpool::get --
327 | #
328 | # Waits for a job sent with "thread::post" to finish.
329 | #
330 | # Arguments:
331 | # tpid Name of the pool shared array.
332 | # jobid Id of the previously posted job.
333 | #
334 | # Side Effects:
335 | # None.
336 | #
337 | # Results:
338 | # Result of the job. If the job resulted in error, it sets
339 | # the global errorInfo and errorCode variables accordingly.
340 | #
341 |
342 | proc tpool::get {tpid jobid} {
343 |
344 | variable jobsdone
345 |
346 | if {[lindex $jobsdone($jobid) 1] != 0} {
347 | eval error [lrange $jobsdone($jobid) 2 end]
348 | }
349 |
350 | return [lindex $jobsdone($jobid) 2]
351 | }
352 |
353 | #
354 | # tpool::preserve --
355 | #
356 | # Increments the reference counter of the threadpool, reserving it
357 | # for the private usage..
358 | #
359 | # Arguments:
360 | # tpid Name of the pool shared array.
361 | #
362 | # Side Effects:
363 | # None.
364 | #
365 | # Results:
366 | # Current number of threadpool reservations.
367 | #
368 |
369 | proc tpool::preserve {tpid} {
370 | tsv::incr $tpid refcounter
371 | }
372 |
373 | #
374 | # tpool::release --
375 | #
376 | # Decrements the reference counter of the threadpool, eventually
377 | # tearing the pool down if this was the last reservation.
378 | #
379 | # Arguments:
380 | # tpid Name of the pool shared array.
381 | #
382 | # Side Effects:
383 | # If the number of reservations drops to zero or below
384 | # the threadpool is teared down.
385 | #
386 | # Results:
387 | # Current number of threadpool reservations.
388 | #
389 |
390 | proc tpool::release {tpid} {
391 |
392 | tsv::lock $tpid {
393 | if {[tsv::incr $tpid refcounter -1] <= 0} {
394 | # Release all workers threads
395 | foreach t [tsv::set $tpid thrworkers] {
396 | thread::release -wait $t
397 | }
398 | tsv::unset $tpid ; # This is not an error; it works!
399 | }
400 | }
401 | }
402 |
403 | #
404 | # Private procedures, not a part of the threadpool API.
405 | #
406 |
407 | #
408 | # tpool::Worker --
409 | #
410 | # Creates new worker thread. This procedure must be executed
411 | # under the tsv lock.
412 | #
413 | # Arguments:
414 | # tpid Name of the pool shared array.
415 | #
416 | # Side Effects:
417 | # Depends on the thread initialization script.
418 | #
419 | # Results:
420 | # None.
421 | #
422 |
423 | proc tpool::Worker {tpid} {
424 |
425 | #
426 | # Create new worker thread
427 | #
428 |
429 | set tid [thread::create]
430 |
431 | thread::send $tid [tsv::set $tpid -initcmd]
432 | thread::preserve $tid
433 |
434 | tsv::incr $tpid numworkers
435 | tsv::lpush $tpid thrworkers $tid
436 |
437 | #
438 | # Signalize waiter threads if any
439 | #
440 |
441 | set waiter [tsv::lpop $tpid thrwaiters]
442 | if {$waiter != ""} {
443 | thread::send -async $waiter [subst {
444 | set [namespace current]::waiter 1
445 | }]
446 | }
447 | }
448 |
449 | #
450 | # tpool::Timer --
451 | #
452 | # This procedure should be executed within the worker thread only.
453 | # It registers the callback for terminating the idle thread.
454 | #
455 | # Arguments:
456 | # tpid Name of the pool shared array.
457 | #
458 | # Side Effects:
459 | # Thread may eventually exit.
460 | #
461 | # Results:
462 | # None.
463 | #
464 |
465 | proc tpool::Timer {tpid} {
466 |
467 | tsv::lock $tpid {
468 | if {[tsv::set $tpid numworkers] > [tsv::set $tpid -minworkers]} {
469 |
470 | #
471 | # We have more workers than needed, so kill this one.
472 | # We first splice ourselves from the list of active
473 | # workers, adjust the number of workers and release
474 | # this thread, which may exit eventually.
475 | #
476 |
477 | set x [tsv::lsearch $tpid thrworkers [thread::id]]
478 | if {$x >= 0} {
479 | tsv::lreplace $tpid thrworkers $x $x
480 | tsv::incr $tpid numworkers -1
481 | set exitcmd [tsv::set $tpid -exitcmd]
482 | if {$exitcmd != ""} {
483 | catch {eval $exitcmd}
484 | }
485 | thread::release
486 | }
487 | }
488 | }
489 | }
490 |
491 | #
492 | # tpool::Run --
493 | #
494 | # This procedure should be executed within the worker thread only.
495 | # It performs the actual command execution in the worker thread.
496 | #
497 | # Arguments:
498 | # tpid Name of the pool shared array.
499 | # jid The job id
500 | # cmd The command to execute
501 | #
502 | # Side Effects:
503 | # Many, depending of the passed command
504 | #
505 | # Results:
506 | # List for passing the evaluation result and status back.
507 | #
508 |
509 | proc tpool::Run {tpid jid cmd} {
510 |
511 | #
512 | # Cancel the idle timer callback, if any.
513 | #
514 |
515 | variable afterevent
516 | if {$afterevent != ""} {
517 | after cancel $afterevent
518 | }
519 |
520 | #
521 | # Evaluate passed command and build the result list.
522 | #
523 |
524 | set code [catch {uplevel \#0 $cmd} ret]
525 | if {$code == 0} {
526 | set res [list $jid 0 $ret]
527 | } else {
528 | set res [list $jid $code $ret $::errorInfo $::errorCode]
529 | }
530 |
531 | #
532 | # Check to see if any caller is waiting to be serviced.
533 | # If yes, kick it out of the waiting state.
534 | #
535 |
536 | set ns [namespace current]
537 |
538 | tsv::lock $tpid {
539 | tsv::lpush $tpid thrworkers [thread::id]
540 | set waiter [tsv::lpop $tpid thrwaiters]
541 | if {$waiter != ""} {
542 | thread::send -async $waiter [subst {
543 | set ${ns}::waiter 1
544 | }]
545 | }
546 | }
547 |
548 | #
549 | # Release the thread. If this turns out to be
550 | # the last refcount held, don't bother to do
551 | # any more work, since thread will soon exit.
552 | #
553 |
554 | if {[thread::release] <= 0} {
555 | return $res
556 | }
557 |
558 | #
559 | # Register the idle timer again.
560 | #
561 |
562 | if {[set idle [tsv::set $tpid -idletime]]} {
563 | set afterevent [after $idle [subst {
564 | ${ns}::Timer $tpid
565 | }]]
566 | }
567 |
568 | return $res
569 | }
570 |
571 | # EOF $RCSfile$
572 |
573 | # Emacs Setup Variables
574 | # Local Variables:
575 | # mode: Tcl
576 | # indent-tabs-mode: nil
577 | # tcl-basic-offset: 4
578 | # End:
579 |
580 |
--------------------------------------------------------------------------------