1/*-
2 * See the file LICENSE for redistribution information.
3 *
4 * Copyright (c) 1999,2008 Oracle.  All rights reserved.
5 *
6 * $Id: tcl_compat.c,v 12.8 2008/01/08 20:58:51 bostic Exp $
7 */
8
9#include "db_config.h"
10#ifdef CONFIG_TEST
11
12#define	DB_DBM_HSEARCH	1
13#include "db_int.h"
14#ifdef HAVE_SYSTEM_INCLUDE_FILES
15#include <tcl.h>
16#endif
17#include "dbinc/tcl_db.h"
18
19/*
20 * bdb_HCommand --
21 *	Implements h* functions.
22 *
23 * PUBLIC: int bdb_HCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
24 */
25int
26bdb_HCommand(interp, objc, objv)
27	Tcl_Interp *interp;		/* Interpreter */
28	int objc;			/* How many arguments? */
29	Tcl_Obj *CONST objv[];		/* The argument objects */
30{
31	static const char *hcmds[] = {
32		"hcreate",
33		"hdestroy",
34		"hsearch",
35		NULL
36	};
37	enum hcmds {
38		HHCREATE,
39		HHDESTROY,
40		HHSEARCH
41	};
42	static const char *srchacts[] = {
43		"enter",
44		"find",
45		NULL
46	};
47	enum srchacts {
48		ACT_ENTER,
49		ACT_FIND
50	};
51	ENTRY item, *hres;
52	ACTION action;
53	int actindex, cmdindex, nelem, result, ret;
54	Tcl_Obj *res;
55
56	result = TCL_OK;
57	/*
58	 * Get the command name index from the object based on the cmds
59	 * defined above.  This SHOULD NOT fail because we already checked
60	 * in the 'berkdb' command.
61	 */
62	if (Tcl_GetIndexFromObj(interp,
63	    objv[1], hcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
64		return (IS_HELP(objv[1]));
65
66	res = NULL;
67	switch ((enum hcmds)cmdindex) {
68	case HHCREATE:
69		/*
70		 * Must be 1 arg, nelem.  Error if not.
71		 */
72		if (objc != 3) {
73			Tcl_WrongNumArgs(interp, 2, objv, "nelem");
74			return (TCL_ERROR);
75		}
76		result = Tcl_GetIntFromObj(interp, objv[2], &nelem);
77		if (result == TCL_OK) {
78			_debug_check();
79			ret = hcreate((size_t)nelem) == 0 ? 1: 0;
80			(void)_ReturnSetup(
81			    interp, ret, DB_RETOK_STD(ret), "hcreate");
82		}
83		break;
84	case HHSEARCH:
85		/*
86		 * 3 args for this.  Error if different.
87		 */
88		if (objc != 5) {
89			Tcl_WrongNumArgs(interp, 2, objv, "key data action");
90			return (TCL_ERROR);
91		}
92		item.key = Tcl_GetStringFromObj(objv[2], NULL);
93		item.data = Tcl_GetStringFromObj(objv[3], NULL);
94		if (Tcl_GetIndexFromObj(interp, objv[4], srchacts,
95		    "action", TCL_EXACT, &actindex) != TCL_OK)
96			return (IS_HELP(objv[4]));
97		switch ((enum srchacts)actindex) {
98		case ACT_ENTER:
99			action = ENTER;
100			break;
101		default:
102		case ACT_FIND:
103			action = FIND;
104			break;
105		}
106		_debug_check();
107		hres = hsearch(item, action);
108		if (hres == NULL)
109			Tcl_SetResult(interp, "-1", TCL_STATIC);
110		else if (action == FIND)
111			Tcl_SetResult(interp, (char *)hres->data, TCL_STATIC);
112		else
113			/* action is ENTER */
114			Tcl_SetResult(interp, "0", TCL_STATIC);
115
116		break;
117	case HHDESTROY:
118		/*
119		 * No args for this.  Error if there are some.
120		 */
121		if (objc != 2) {
122			Tcl_WrongNumArgs(interp, 2, objv, NULL);
123			return (TCL_ERROR);
124		}
125		_debug_check();
126		hdestroy();
127		res = Tcl_NewIntObj(0);
128		break;
129	}
130	/*
131	 * Only set result if we have a res.  Otherwise, lower
132	 * functions have already done so.
133	 */
134	if (result == TCL_OK && res)
135		Tcl_SetObjResult(interp, res);
136	return (result);
137}
138
139/*
140 *
141 * bdb_NdbmOpen --
142 *	Opens an ndbm database.
143 *
144 * PUBLIC: #if DB_DBM_HSEARCH != 0
145 * PUBLIC: int bdb_NdbmOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBM **));
146 * PUBLIC: #endif
147 */
148int
149bdb_NdbmOpen(interp, objc, objv, dbpp)
150	Tcl_Interp *interp;		/* Interpreter */
151	int objc;			/* How many arguments? */
152	Tcl_Obj *CONST objv[];		/* The argument objects */
153	DBM **dbpp;			/* Dbm pointer */
154{
155	static const char *ndbopen[] = {
156		"-create",
157		"-mode",
158		"-rdonly",
159		"-truncate",
160		"--",
161		NULL
162	};
163	enum ndbopen {
164		NDB_CREATE,
165		NDB_MODE,
166		NDB_RDONLY,
167		NDB_TRUNC,
168		NDB_ENDARG
169	};
170
171	int endarg, i, mode, open_flags, optindex, read_only, result, ret;
172	char *arg, *db;
173
174	result = TCL_OK;
175	endarg = mode = open_flags = read_only = 0;
176
177	if (objc < 2) {
178		Tcl_WrongNumArgs(interp, 2, objv, "?args?");
179		return (TCL_ERROR);
180	}
181
182	/*
183	 * Get the option name index from the object based on the args
184	 * defined above.
185	 */
186	i = 2;
187	while (i < objc) {
188		if (Tcl_GetIndexFromObj(interp, objv[i], ndbopen, "option",
189		    TCL_EXACT, &optindex) != TCL_OK) {
190			arg = Tcl_GetStringFromObj(objv[i], NULL);
191			if (arg[0] == '-') {
192				result = IS_HELP(objv[i]);
193				goto error;
194			} else
195				Tcl_ResetResult(interp);
196			break;
197		}
198		i++;
199		switch ((enum ndbopen)optindex) {
200		case NDB_CREATE:
201			open_flags |= O_CREAT;
202			break;
203		case NDB_RDONLY:
204			read_only = 1;
205			break;
206		case NDB_TRUNC:
207			open_flags |= O_TRUNC;
208			break;
209		case NDB_MODE:
210			if (i >= objc) {
211				Tcl_WrongNumArgs(interp, 2, objv,
212				    "?-mode mode?");
213				result = TCL_ERROR;
214				break;
215			}
216			/*
217			 * Don't need to check result here because
218			 * if TCL_ERROR, the error message is already
219			 * set up, and we'll bail out below.  If ok,
220			 * the mode is set and we go on.
221			 */
222			result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
223			break;
224		case NDB_ENDARG:
225			endarg = 1;
226			break;
227		}
228
229		/*
230		 * If, at any time, parsing the args we get an error,
231		 * bail out and return.
232		 */
233		if (result != TCL_OK)
234			goto error;
235		if (endarg)
236			break;
237	}
238	if (result != TCL_OK)
239		goto error;
240
241	/*
242	 * Any args we have left, (better be 0, or 1 left) is a
243	 * file name.  If we have 0, then an in-memory db.  If
244	 * there is 1, a db name.
245	 */
246	db = NULL;
247	if (i != objc && i != objc - 1) {
248		Tcl_WrongNumArgs(interp, 2, objv, "?args? ?file?");
249		result = TCL_ERROR;
250		goto error;
251	}
252	if (i != objc)
253		db = Tcl_GetStringFromObj(objv[objc - 1], NULL);
254
255	/*
256	 * When we get here, we have already parsed all of our args
257	 * and made all our calls to set up the database.  Everything
258	 * is okay so far, no errors, if we get here.
259	 *
260	 * Now open the database.
261	 */
262	if (read_only)
263		open_flags |= O_RDONLY;
264	else
265		open_flags |= O_RDWR;
266	_debug_check();
267	if ((*dbpp = dbm_open(db, open_flags, mode)) == NULL) {
268		ret = Tcl_GetErrno();
269		result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
270		    "db open");
271		goto error;
272	}
273	return (TCL_OK);
274
275error:
276	*dbpp = NULL;
277	return (result);
278}
279
280/*
281 * bdb_DbmCommand --
282 *	Implements "dbm" commands.
283 *
284 * PUBLIC: #if DB_DBM_HSEARCH != 0
285 * PUBLIC: int bdb_DbmCommand
286 * PUBLIC:     __P((Tcl_Interp *, int, Tcl_Obj * CONST*, int, DBM *));
287 * PUBLIC: #endif
288 */
289int
290bdb_DbmCommand(interp, objc, objv, flag, dbm)
291	Tcl_Interp *interp;		/* Interpreter */
292	int objc;			/* How many arguments? */
293	Tcl_Obj *CONST objv[];		/* The argument objects */
294	int flag;			/* Which db interface */
295	DBM *dbm;			/* DBM pointer */
296{
297	static const char *dbmcmds[] = {
298		"dbmclose",
299		"dbminit",
300		"delete",
301		"fetch",
302		"firstkey",
303		"nextkey",
304		"store",
305		NULL
306	};
307	enum dbmcmds {
308		DBMCLOSE,
309		DBMINIT,
310		DBMDELETE,
311		DBMFETCH,
312		DBMFIRST,
313		DBMNEXT,
314		DBMSTORE
315	};
316	static const char *stflag[] = {
317		"insert",	"replace",
318		NULL
319	};
320	enum stflag {
321		STINSERT,	STREPLACE
322	};
323	datum key, data;
324	void *dtmp, *ktmp;
325	u_int32_t size;
326	int cmdindex, freedata, freekey, stindex, result, ret;
327	char *name, *t;
328
329	result = TCL_OK;
330	freekey = freedata = 0;
331	dtmp = ktmp = NULL;
332
333	/*
334	 * Get the command name index from the object based on the cmds
335	 * defined above.  This SHOULD NOT fail because we already checked
336	 * in the 'berkdb' command.
337	 */
338	if (Tcl_GetIndexFromObj(interp,
339	    objv[1], dbmcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
340		return (IS_HELP(objv[1]));
341
342	switch ((enum dbmcmds)cmdindex) {
343	case DBMCLOSE:
344		/*
345		 * No arg for this.  Error if different.
346		 */
347		if (objc != 2) {
348			Tcl_WrongNumArgs(interp, 2, objv, NULL);
349			return (TCL_ERROR);
350		}
351		_debug_check();
352		if (flag == DBTCL_DBM)
353			ret = dbmclose();
354		else {
355			Tcl_SetResult(interp,
356			    "Bad interface flag for command", TCL_STATIC);
357			return (TCL_ERROR);
358		}
359		(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "dbmclose");
360		break;
361	case DBMINIT:
362		/*
363		 * Must be 1 arg - file.
364		 */
365		if (objc != 3) {
366			Tcl_WrongNumArgs(interp, 2, objv, "file");
367			return (TCL_ERROR);
368		}
369		name = Tcl_GetStringFromObj(objv[2], NULL);
370		if (flag == DBTCL_DBM)
371			ret = dbminit(name);
372		else {
373			Tcl_SetResult(interp, "Bad interface flag for command",
374			    TCL_STATIC);
375			return (TCL_ERROR);
376		}
377		(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "dbminit");
378		break;
379	case DBMFETCH:
380		/*
381		 * 1 arg for this.  Error if different.
382		 */
383		if (objc != 3) {
384			Tcl_WrongNumArgs(interp, 2, objv, "key");
385			return (TCL_ERROR);
386		}
387		if ((ret = _CopyObjBytes(
388		    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
389			result = _ReturnSetup(interp, ret,
390			    DB_RETOK_STD(ret), "dbm fetch");
391			goto out;
392		}
393		key.dsize = (int)size;
394		key.dptr = (char *)ktmp;
395		_debug_check();
396		if (flag == DBTCL_DBM)
397			data = fetch(key);
398		else if (flag == DBTCL_NDBM)
399			data = dbm_fetch(dbm, key);
400		else {
401			Tcl_SetResult(interp,
402			    "Bad interface flag for command", TCL_STATIC);
403			result = TCL_ERROR;
404			goto out;
405		}
406		if (data.dptr == NULL ||
407		    (ret = __os_malloc(NULL, (size_t)data.dsize + 1, &t)) != 0)
408			Tcl_SetResult(interp, "-1", TCL_STATIC);
409		else {
410			memcpy(t, data.dptr, (size_t)data.dsize);
411			t[data.dsize] = '\0';
412			Tcl_SetResult(interp, t, TCL_VOLATILE);
413			__os_free(NULL, t);
414		}
415		break;
416	case DBMSTORE:
417		/*
418		 * 2 args for this.  Error if different.
419		 */
420		if (objc != 4 && flag == DBTCL_DBM) {
421			Tcl_WrongNumArgs(interp, 2, objv, "key data");
422			return (TCL_ERROR);
423		}
424		if (objc != 5 && flag == DBTCL_NDBM) {
425			Tcl_WrongNumArgs(interp, 2, objv, "key data action");
426			return (TCL_ERROR);
427		}
428		if ((ret = _CopyObjBytes(
429		    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
430			result = _ReturnSetup(interp, ret,
431			    DB_RETOK_STD(ret), "dbm fetch");
432			goto out;
433		}
434		key.dsize = (int)size;
435		key.dptr = (char *)ktmp;
436		if ((ret = _CopyObjBytes(
437		    interp, objv[3], &dtmp, &size, &freedata)) != 0) {
438			result = _ReturnSetup(interp, ret,
439			    DB_RETOK_STD(ret), "dbm fetch");
440			goto out;
441		}
442		data.dsize = (int)size;
443		data.dptr = (char *)dtmp;
444		_debug_check();
445		if (flag == DBTCL_DBM)
446			ret = store(key, data);
447		else if (flag == DBTCL_NDBM) {
448			if (Tcl_GetIndexFromObj(interp, objv[4], stflag,
449			    "flag", TCL_EXACT, &stindex) != TCL_OK)
450				return (IS_HELP(objv[4]));
451			switch ((enum stflag)stindex) {
452			case STINSERT:
453				flag = DBM_INSERT;
454				break;
455			case STREPLACE:
456				flag = DBM_REPLACE;
457				break;
458			}
459			ret = dbm_store(dbm, key, data, flag);
460		} else {
461			Tcl_SetResult(interp,
462			    "Bad interface flag for command", TCL_STATIC);
463			return (TCL_ERROR);
464		}
465		(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "store");
466		break;
467	case DBMDELETE:
468		/*
469		 * 1 arg for this.  Error if different.
470		 */
471		if (objc != 3) {
472			Tcl_WrongNumArgs(interp, 2, objv, "key");
473			return (TCL_ERROR);
474		}
475		if ((ret = _CopyObjBytes(
476		    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
477			result = _ReturnSetup(interp, ret,
478			    DB_RETOK_STD(ret), "dbm fetch");
479			goto out;
480		}
481		key.dsize = (int)size;
482		key.dptr = (char *)ktmp;
483		_debug_check();
484		if (flag == DBTCL_DBM)
485			ret = delete(key);
486		else if (flag == DBTCL_NDBM)
487			ret = dbm_delete(dbm, key);
488		else {
489			Tcl_SetResult(interp,
490			    "Bad interface flag for command", TCL_STATIC);
491			return (TCL_ERROR);
492		}
493		(void)_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "delete");
494		break;
495	case DBMFIRST:
496		/*
497		 * No arg for this.  Error if different.
498		 */
499		if (objc != 2) {
500			Tcl_WrongNumArgs(interp, 2, objv, NULL);
501			return (TCL_ERROR);
502		}
503		_debug_check();
504		if (flag == DBTCL_DBM)
505			key = firstkey();
506		else if (flag == DBTCL_NDBM)
507			key = dbm_firstkey(dbm);
508		else {
509			Tcl_SetResult(interp,
510			    "Bad interface flag for command", TCL_STATIC);
511			return (TCL_ERROR);
512		}
513		if (key.dptr == NULL ||
514		    (ret = __os_malloc(NULL, (size_t)key.dsize + 1, &t)) != 0)
515			Tcl_SetResult(interp, "-1", TCL_STATIC);
516		else {
517			memcpy(t, key.dptr, (size_t)key.dsize);
518			t[key.dsize] = '\0';
519			Tcl_SetResult(interp, t, TCL_VOLATILE);
520			__os_free(NULL, t);
521		}
522		break;
523	case DBMNEXT:
524		/*
525		 * 0 or 1 arg for this.  Error if different.
526		 */
527		_debug_check();
528		if (flag == DBTCL_DBM) {
529			if (objc != 3) {
530				Tcl_WrongNumArgs(interp, 2, objv, NULL);
531				return (TCL_ERROR);
532			}
533			if ((ret = _CopyObjBytes(
534			    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
535				result = _ReturnSetup(interp, ret,
536				    DB_RETOK_STD(ret), "dbm fetch");
537				goto out;
538			}
539			key.dsize = (int)size;
540			key.dptr = (char *)ktmp;
541			data = nextkey(key);
542		} else if (flag == DBTCL_NDBM) {
543			if (objc != 2) {
544				Tcl_WrongNumArgs(interp, 2, objv, NULL);
545				return (TCL_ERROR);
546			}
547			data = dbm_nextkey(dbm);
548		} else {
549			Tcl_SetResult(interp,
550			    "Bad interface flag for command", TCL_STATIC);
551			return (TCL_ERROR);
552		}
553		if (data.dptr == NULL ||
554		    (ret = __os_malloc(NULL, (size_t)data.dsize + 1, &t)) != 0)
555			Tcl_SetResult(interp, "-1", TCL_STATIC);
556		else {
557			memcpy(t, data.dptr, (size_t)data.dsize);
558			t[data.dsize] = '\0';
559			Tcl_SetResult(interp, t, TCL_VOLATILE);
560			__os_free(NULL, t);
561		}
562		break;
563	}
564
565out:	if (dtmp != NULL && freedata)
566		__os_free(NULL, dtmp);
567	if (ktmp != NULL && freekey)
568		__os_free(NULL, ktmp);
569	return (result);
570}
571
572/*
573 * ndbm_Cmd --
574 *	Implements the "ndbm" widget.
575 *
576 * PUBLIC: int ndbm_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
577 */
578int
579ndbm_Cmd(clientData, interp, objc, objv)
580	ClientData clientData;		/* DB handle */
581	Tcl_Interp *interp;		/* Interpreter */
582	int objc;			/* How many arguments? */
583	Tcl_Obj *CONST objv[];		/* The argument objects */
584{
585	static const char *ndbcmds[] = {
586		"clearerr",
587		"close",
588		"delete",
589		"dirfno",
590		"error",
591		"fetch",
592		"firstkey",
593		"nextkey",
594		"pagfno",
595		"rdonly",
596		"store",
597		NULL
598	};
599	enum ndbcmds {
600		NDBCLRERR,
601		NDBCLOSE,
602		NDBDELETE,
603		NDBDIRFNO,
604		NDBERR,
605		NDBFETCH,
606		NDBFIRST,
607		NDBNEXT,
608		NDBPAGFNO,
609		NDBRDONLY,
610		NDBSTORE
611	};
612	DBM *dbp;
613	DBTCL_INFO *dbip;
614	Tcl_Obj *res;
615	int cmdindex, result, ret;
616
617	Tcl_ResetResult(interp);
618	dbp = (DBM *)clientData;
619	dbip = _PtrToInfo((void *)dbp);
620	result = TCL_OK;
621	if (objc <= 1) {
622		Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
623		return (TCL_ERROR);
624	}
625	if (dbp == NULL) {
626		Tcl_SetResult(interp, "NULL db pointer", TCL_STATIC);
627		return (TCL_ERROR);
628	}
629	if (dbip == NULL) {
630		Tcl_SetResult(interp, "NULL db info pointer", TCL_STATIC);
631		return (TCL_ERROR);
632	}
633
634	/*
635	 * Get the command name index from the object based on the dbcmds
636	 * defined above.
637	 */
638	if (Tcl_GetIndexFromObj(interp,
639	    objv[1], ndbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
640		return (IS_HELP(objv[1]));
641
642	res = NULL;
643	switch ((enum ndbcmds)cmdindex) {
644	case NDBCLOSE:
645		_debug_check();
646		dbm_close(dbp);
647		(void)Tcl_DeleteCommand(interp, dbip->i_name);
648		_DeleteInfo(dbip);
649		res = Tcl_NewIntObj(0);
650		break;
651	case NDBDELETE:
652	case NDBFETCH:
653	case NDBFIRST:
654	case NDBNEXT:
655	case NDBSTORE:
656		result = bdb_DbmCommand(interp, objc, objv, DBTCL_NDBM, dbp);
657		break;
658	case NDBCLRERR:
659		/*
660		 * No args for this.  Error if there are some.
661		 */
662		if (objc > 2) {
663			Tcl_WrongNumArgs(interp, 2, objv, NULL);
664			return (TCL_ERROR);
665		}
666		_debug_check();
667		ret = dbm_clearerr(dbp);
668		if (ret)
669			(void)_ReturnSetup(
670			    interp, ret, DB_RETOK_STD(ret), "clearerr");
671		else
672			res = Tcl_NewIntObj(ret);
673		break;
674	case NDBDIRFNO:
675		/*
676		 * No args for this.  Error if there are some.
677		 */
678		if (objc > 2) {
679			Tcl_WrongNumArgs(interp, 2, objv, NULL);
680			return (TCL_ERROR);
681		}
682		_debug_check();
683		ret = dbm_dirfno(dbp);
684		res = Tcl_NewIntObj(ret);
685		break;
686	case NDBPAGFNO:
687		/*
688		 * No args for this.  Error if there are some.
689		 */
690		if (objc > 2) {
691			Tcl_WrongNumArgs(interp, 2, objv, NULL);
692			return (TCL_ERROR);
693		}
694		_debug_check();
695		ret = dbm_pagfno(dbp);
696		res = Tcl_NewIntObj(ret);
697		break;
698	case NDBERR:
699		/*
700		 * No args for this.  Error if there are some.
701		 */
702		if (objc > 2) {
703			Tcl_WrongNumArgs(interp, 2, objv, NULL);
704			return (TCL_ERROR);
705		}
706		_debug_check();
707		ret = dbm_error(dbp);
708		Tcl_SetErrno(ret);
709		Tcl_SetResult(interp,
710		    (char *)Tcl_PosixError(interp), TCL_STATIC);
711		break;
712	case NDBRDONLY:
713		/*
714		 * No args for this.  Error if there are some.
715		 */
716		if (objc > 2) {
717			Tcl_WrongNumArgs(interp, 2, objv, NULL);
718			return (TCL_ERROR);
719		}
720		_debug_check();
721		ret = dbm_rdonly(dbp);
722		if (ret)
723			(void)_ReturnSetup(
724			    interp, ret, DB_RETOK_STD(ret), "rdonly");
725		else
726			res = Tcl_NewIntObj(ret);
727		break;
728	}
729
730	/*
731	 * Only set result if we have a res.  Otherwise, lower functions have
732	 * already done so.
733	 */
734	if (result == TCL_OK && res)
735		Tcl_SetObjResult(interp, res);
736	return (result);
737}
738#endif /* CONFIG_TEST */
739