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