1 /*-
2 * Copyright (c) 2004, 2020 Oracle and/or its affiliates. All rights reserved.
3 *
4 * See the file LICENSE for license information.
5 *
6 * $Id$
7 */
8
9 #include "db_config.h"
10
11 #include "db_int.h"
12 #ifdef HAVE_SYSTEM_INCLUDE_FILES
13 #include <tcl.h>
14 #endif
15 #include "dbinc/tcl_db.h"
16
17 #ifdef CONFIG_TEST
18 /*
19 * PUBLIC: int tcl_Mutex __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
20 * PUBLIC: DB_ENV *));
21 *
22 * tcl_Mutex --
23 * Implements dbenv->mutex_alloc method.
24 */
25 int
tcl_Mutex(interp,objc,objv,dbenv)26 tcl_Mutex(interp, objc, objv, dbenv)
27 Tcl_Interp *interp; /* Interpreter */
28 int objc; /* How many arguments? */
29 Tcl_Obj *CONST objv[]; /* The argument objects */
30 DB_ENV *dbenv; /* Environment */
31 {
32 static const char *which[] = {
33 "-process_only",
34 "-self_block",
35 NULL
36 };
37 enum which {
38 PROCONLY,
39 SELFBLOCK
40 };
41 int arg, i, result, ret;
42 u_int32_t flags;
43 db_mutex_t indx;
44 Tcl_Obj *res;
45
46 result = TCL_OK;
47 flags = 0;
48 Tcl_ResetResult(interp);
49 if (objc < 2) {
50 Tcl_WrongNumArgs(interp, 2, objv,
51 "-proccess_only | -self_block");
52 return (TCL_ERROR);
53 }
54
55 i = 2;
56 while (i < objc) {
57 /*
58 * If there is an arg, make sure it is the right one.
59 */
60 if (Tcl_GetIndexFromObj(interp, objv[i], which, "option",
61 TCL_EXACT, &arg) != TCL_OK)
62 return (IS_HELP(objv[i]));
63 i++;
64 switch ((enum which)arg) {
65 case PROCONLY:
66 flags |= DB_MUTEX_PROCESS_ONLY;
67 break;
68 case SELFBLOCK:
69 flags |= DB_MUTEX_SELF_BLOCK;
70 break;
71 }
72 }
73 res = NULL;
74 ret = dbenv->mutex_alloc(dbenv, flags, &indx);
75 if (ret != 0) {
76 result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
77 "mutex_alloc");
78 Tcl_SetResult(interp, "allocation failed", TCL_STATIC);
79 } else {
80 res = Tcl_NewWideIntObj((Tcl_WideInt)indx);
81 Tcl_SetObjResult(interp, res);
82 }
83 return (result);
84 }
85
86 /*
87 * tcl_MutexFailchkTimeout --
88 *
89 * PUBLIC: int tcl_MutexFailchkTimeout __P((Tcl_Interp *, int,
90 * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
91 */
92 int
tcl_MutexFailchkTimeout(interp,objc,objv,dbenv)93 tcl_MutexFailchkTimeout(interp, objc, objv, dbenv)
94 Tcl_Interp *interp; /* Interpreter */
95 int objc; /* How many arguments? */
96 Tcl_Obj *CONST objv[]; /* The argument objects */
97 DB_ENV *dbenv; /* Environment pointer */
98 {
99 long timeout;
100 int result, ret;
101
102 /*
103 * One arg, the timeout.
104 */
105 if (objc != 3) {
106 Tcl_WrongNumArgs(interp, 2, objv, "?timeout?");
107 return (TCL_ERROR);
108 }
109 result = Tcl_GetLongFromObj(interp, objv[2], &timeout);
110 if (result != TCL_OK)
111 return (result);
112 _debug_check();
113 ret = dbenv->set_timeout(dbenv, (u_int32_t)timeout,
114 DB_SET_MUTEX_FAILCHK_TIMEOUT);
115 result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
116 "mutex failchk timeout");
117 return (result);
118 }
119
120 /*
121 * PUBLIC: int tcl_MutFree __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
122 * PUBLIC: DB_ENV *));
123 *
124 * tcl_MutFree --
125 * Implements dbenv->mutex_free method.
126 */
127 int
tcl_MutFree(interp,objc,objv,dbenv)128 tcl_MutFree(interp, objc, objv, dbenv)
129 Tcl_Interp *interp; /* Interpreter */
130 int objc; /* How many arguments? */
131 Tcl_Obj *CONST objv[]; /* The argument objects */
132 DB_ENV *dbenv; /* Environment */
133 {
134 int result, ret;
135 Tcl_WideInt tmp;
136 db_mutex_t indx;
137
138 if (objc != 3) {
139 Tcl_WrongNumArgs(interp, 3, objv, "mutexid");
140 return (TCL_ERROR);
141 }
142 if ((result = Tcl_GetWideIntFromObj(interp, objv[2], &tmp)) != TCL_OK)
143 return (result);
144 indx = (db_mutex_t)tmp;
145 ret = dbenv->mutex_free(dbenv, indx);
146 return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env mutex_free"));
147 }
148
149 /*
150 * PUBLIC: int tcl_MutGet __P((Tcl_Interp *, DB_ENV *, int));
151 *
152 * tcl_MutGet --
153 * Implements dbenv->mutex_get_* methods.
154 */
155 int
tcl_MutGet(interp,dbenv,op)156 tcl_MutGet(interp, dbenv, op)
157 Tcl_Interp *interp; /* Interpreter */
158 DB_ENV *dbenv; /* Environment */
159 int op; /* Which item to get */
160 {
161 Tcl_Obj *res;
162 u_int32_t val;
163 int result, ret;
164
165 res = NULL;
166 val = 0;
167 ret = 0;
168
169 switch (op) {
170 case DBTCL_MUT_ALIGN:
171 ret = dbenv->mutex_get_align(dbenv, &val);
172 break;
173 case DBTCL_MUT_INCR:
174 ret = dbenv->mutex_get_increment(dbenv, &val);
175 break;
176 case DBTCL_MUT_INIT:
177 ret = dbenv->mutex_get_init(dbenv, &val);
178 break;
179 case DBTCL_MUT_MAX:
180 ret = dbenv->mutex_get_max(dbenv, &val);
181 break;
182 case DBTCL_MUT_TAS:
183 ret = dbenv->mutex_get_tas_spins(dbenv, &val);
184 break;
185 default:
186 return (TCL_ERROR);
187 }
188 if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
189 "mutex_get")) == TCL_OK) {
190 res = Tcl_NewLongObj((long)val);
191 Tcl_SetObjResult(interp, res);
192 }
193 return (result);
194 }
195
196 /*
197 * PUBLIC: int tcl_MutLock __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
198 * PUBLIC: DB_ENV *));
199 *
200 * tcl_MutLock --
201 * Implements dbenv->mutex_lock method.
202 */
203 int
tcl_MutLock(interp,objc,objv,dbenv)204 tcl_MutLock(interp, objc, objv, dbenv)
205 Tcl_Interp *interp; /* Interpreter */
206 int objc; /* How many arguments? */
207 Tcl_Obj *CONST objv[]; /* The argument objects */
208 DB_ENV *dbenv; /* Environment */
209 {
210 int result, ret;
211 Tcl_WideInt tmp;
212 db_mutex_t indx;
213
214 if (objc != 3) {
215 Tcl_WrongNumArgs(interp, 3, objv, "mutexid");
216 return (TCL_ERROR);
217 }
218 if ((result = Tcl_GetWideIntFromObj(interp, objv[2], &tmp)) != TCL_OK)
219 return (result);
220 indx = (db_mutex_t)tmp;
221 ret = dbenv->mutex_lock(dbenv, indx);
222 return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env mutex_lock"));
223 }
224
225 /*
226 * PUBLIC: int tcl_MutSet __P((Tcl_Interp *, Tcl_Obj *,
227 * PUBLIC: DB_ENV *, int));
228 *
229 * tcl_MutSet --
230 * Implements dbenv->mutex_set methods.
231 */
232 int
tcl_MutSet(interp,obj,dbenv,op)233 tcl_MutSet(interp, obj, dbenv, op)
234 Tcl_Interp *interp; /* Interpreter */
235 Tcl_Obj *obj; /* The argument object */
236 DB_ENV *dbenv; /* Environment */
237 int op; /* Which item to set */
238 {
239 int result, ret;
240 u_int32_t val;
241
242 if ((result = _GetUInt32(interp, obj, &val)) != TCL_OK)
243 return (result);
244 switch (op) {
245 case DBTCL_MUT_ALIGN:
246 ret = dbenv->mutex_set_align(dbenv, val);
247 break;
248 case DBTCL_MUT_INCR:
249 ret = dbenv->mutex_set_increment(dbenv, val);
250 break;
251 case DBTCL_MUT_INIT:
252 ret = dbenv->mutex_set_init(dbenv, val);
253 break;
254 case DBTCL_MUT_MAX:
255 ret = dbenv->mutex_set_max(dbenv, val);
256 break;
257 case DBTCL_MUT_TAS:
258 ret = dbenv->mutex_set_tas_spins(dbenv, val);
259 break;
260 default:
261 return (TCL_ERROR);
262 }
263 return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env mutex_set"));
264 }
265
266 /*
267 * PUBLIC: int tcl_MutStat __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
268 * PUBLIC: DB_ENV *));
269 *
270 * tcl_MutStat --
271 * Implements dbenv->mutex_stat method.
272 */
273 int
tcl_MutStat(interp,objc,objv,dbenv)274 tcl_MutStat(interp, objc, objv, dbenv)
275 Tcl_Interp *interp; /* Interpreter */
276 int objc; /* How many arguments? */
277 Tcl_Obj *CONST objv[]; /* The argument objects */
278 DB_ENV *dbenv; /* Environment */
279 {
280 DB_MUTEX_STAT *sp;
281 Tcl_Obj *res;
282 u_int32_t flag;
283 int result, ret;
284 char *arg;
285
286 result = TCL_OK;
287 flag = 0;
288
289 if (objc > 3) {
290 Tcl_WrongNumArgs(interp, 2, objv, "?-clear?");
291 return (TCL_ERROR);
292 }
293
294 if (objc == 3) {
295 arg = Tcl_GetStringFromObj(objv[2], NULL);
296 if (strcmp(arg, "-clear") == 0)
297 flag = DB_STAT_CLEAR;
298 else {
299 Tcl_SetResult(interp,
300 "db stat: unknown arg", TCL_STATIC);
301 return (TCL_ERROR);
302 }
303 }
304
305 _debug_check();
306 ret = dbenv->mutex_stat(dbenv, &sp, flag);
307 result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mutex stat");
308 if (result == TCL_ERROR)
309 return (result);
310
311 res = Tcl_NewObj();
312 MAKE_STAT_LIST("Mutex align", sp->st_mutex_align);
313 MAKE_STAT_LIST("Mutex TAS spins", sp->st_mutex_tas_spins);
314 MAKE_STAT_LIST("Initial mutex count", sp->st_mutex_init);
315 MAKE_STAT_LIST("Mutex count", sp->st_mutex_cnt);
316 MAKE_STAT_LIST("Mutex max", sp->st_mutex_max);
317 MAKE_STAT_LIST("Free mutexes", sp->st_mutex_free);
318 MAKE_STAT_LIST("Mutexes in use", sp->st_mutex_inuse);
319 MAKE_STAT_LIST("Max mutexes in use", sp->st_mutex_inuse_max);
320 MAKE_STAT_LIST("Mutex region size", sp->st_regsize);
321 MAKE_STAT_LIST("Mutex region max", sp->st_regmax);
322 MAKE_WSTAT_LIST("Number of region waits", sp->st_region_wait);
323 MAKE_WSTAT_LIST("Number of region no waits", sp->st_region_nowait);
324 Tcl_SetObjResult(interp, res);
325
326 /*
327 * The 'error' label is used by the MAKE_STAT_LIST macro.
328 * Therefore we cannot remove it, and also we know that
329 * sp is allocated at that time.
330 */
331 error: __os_ufree(dbenv->env, sp);
332 return (result);
333 }
334
335 /*
336 * PUBLIC: int tcl_MutStatPrint __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
337 * PUBLIC: DB_ENV *));
338 *
339 * tcl_MutStat --
340 * Implements dbenv->mutex_stat_print method.
341 */
342 int
tcl_MutStatPrint(interp,objc,objv,dbenv)343 tcl_MutStatPrint(interp, objc, objv, dbenv)
344 Tcl_Interp *interp; /* Interpreter */
345 int objc; /* How many arguments? */
346 Tcl_Obj *CONST objv[]; /* The argument objects */
347 DB_ENV *dbenv; /* Environment */
348 {
349 static const char *mutstatprtopts[] = {
350 "-all",
351 "-alloc",
352 "-clear",
353 NULL
354 };
355 enum mutstatprtopts {
356 MUTSTATPRTALL,
357 MUTSTATPRTALLOC,
358 MUTSTATPRTCLEAR
359 };
360 u_int32_t flag;
361 int i, optindex, result, ret;
362
363 result = TCL_OK;
364 flag = 0;
365 i = 2;
366
367 while (i < objc) {
368 if (Tcl_GetIndexFromObj(interp, objv[i], mutstatprtopts,
369 "option", TCL_EXACT, &optindex) != TCL_OK) {
370 result = IS_HELP(objv[i]);
371 goto error;
372 }
373 i++;
374 switch ((enum mutstatprtopts)optindex) {
375 case MUTSTATPRTALL:
376 flag |= DB_STAT_ALL;
377 break;
378 case MUTSTATPRTALLOC:
379 flag |= DB_STAT_ALLOC;
380 break;
381 case MUTSTATPRTCLEAR:
382 flag |= DB_STAT_CLEAR;
383 break;
384 }
385 if (result != TCL_OK)
386 break;
387 }
388 if (result != TCL_OK)
389 goto error;
390
391 _debug_check();
392 ret = dbenv->mutex_stat_print(dbenv, flag);
393 result = _ReturnSetup(interp,
394 ret, DB_RETOK_STD(ret), "dbenv mutex_stat_print");
395 error:
396 return (result);
397 }
398
399 /*
400 * PUBLIC: int tcl_MutUnlock __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
401 * PUBLIC: DB_ENV *));
402 *
403 * tcl_MutUnlock --
404 * Implements dbenv->mutex_unlock method.
405 */
406 int
tcl_MutUnlock(interp,objc,objv,dbenv)407 tcl_MutUnlock(interp, objc, objv, dbenv)
408 Tcl_Interp *interp; /* Interpreter */
409 int objc; /* How many arguments? */
410 Tcl_Obj *CONST objv[]; /* The argument objects */
411 DB_ENV *dbenv; /* Environment */
412 {
413 int result, ret;
414 Tcl_WideInt tmp;
415 db_mutex_t indx;
416
417 if (objc != 3) {
418 Tcl_WrongNumArgs(interp, 3, objv, "mutexid");
419 return (TCL_ERROR);
420 }
421 if ((result = Tcl_GetWideIntFromObj(interp, objv[2], &tmp)) != TCL_OK)
422 return (result);
423 indx = (db_mutex_t)tmp;
424 ret = dbenv->mutex_unlock(dbenv, indx);
425 return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
426 "env mutex_unlock"));
427 }
428 #endif
429