2
* See the file LICENSE for redistribution information.
4
* Copyright (c) 1999-2002
5
* Sleepycat Software. All rights reserved.
11
static const char revid[] = "$Id$";
14
#ifndef NO_SYSTEM_INCLUDES
15
#include <sys/types.h>
23
#define DB_DBM_HSEARCH 1
27
#include "dbinc/db_page.h"
28
#include "dbinc/hash.h"
29
#include "dbinc/tcl_db.h"
31
/* XXX we must declare global data in just one place */
32
DBTCL_GLOBAL __dbtcl_global;
35
* Prototypes for procedures defined later in this file:
37
static int berkdb_Cmd __P((ClientData, Tcl_Interp *, int,
39
static int bdb_EnvOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
40
DBTCL_INFO *, DB_ENV **));
41
static int bdb_DbOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
42
DBTCL_INFO *, DB **));
43
static int bdb_DbRemove __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
44
static int bdb_DbRename __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
45
static int bdb_DbUpgrade __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
46
static int bdb_DbVerify __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
47
static int bdb_Version __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
48
static int bdb_Handles __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
50
static int tcl_bt_compare __P((DB *, const DBT *, const DBT *));
51
static int tcl_compare_callback __P((DB *, const DBT *, const DBT *,
53
static int tcl_dup_compare __P((DB *, const DBT *, const DBT *));
54
static u_int32_t tcl_h_hash __P((DB *, const void *, u_int32_t));
55
static int tcl_rep_send __P((DB_ENV *,
56
const DBT *, const DBT *, int, u_int32_t));
59
static void * tcl_db_malloc __P((size_t));
60
static void * tcl_db_realloc __P((void *, size_t));
61
static void tcl_db_free __P((void *));
67
* This is a package initialization procedure, which is called by Tcl when
68
* this package is to be added to an interpreter. The name is based on the
69
* name of the shared library, currently libdb_tcl-X.Y.so, which Tcl uses
70
* to determine the name of this function.
74
Tcl_Interp *interp; /* Interpreter in which the package is
75
* to be made available. */
79
code = Tcl_PkgProvide(interp, "Db_tcl", "1.0");
83
Tcl_CreateObjCommand(interp, "berkdb", (Tcl_ObjCmdProc *)berkdb_Cmd,
86
* Create shared global debugging variables
88
Tcl_LinkVar(interp, "__debug_on", (char *)&__debug_on, TCL_LINK_INT);
89
Tcl_LinkVar(interp, "__debug_print", (char *)&__debug_print,
91
Tcl_LinkVar(interp, "__debug_stop", (char *)&__debug_stop,
93
Tcl_LinkVar(interp, "__debug_test", (char *)&__debug_test,
95
LIST_INIT(&__db_infohead);
101
* Implements the "berkdb" command.
102
* This command supports three sub commands:
103
* berkdb version - Returns a list {major minor patch}
104
* berkdb env - Creates a new DB_ENV and returns a binding
105
* to a new command of the form dbenvX, where X is an
106
* integer starting at 0 (dbenv0, dbenv1, ...)
107
* berkdb open - Creates a new DB (optionally within
108
* the given environment. Returns a binding to a new
109
* command of the form dbX, where X is an integer
110
* starting at 0 (db0, db1, ...)
113
berkdb_Cmd(notused, interp, objc, objv)
114
ClientData notused; /* Not used. */
115
Tcl_Interp *interp; /* Interpreter */
116
int objc; /* How many arguments? */
117
Tcl_Obj *CONST objv[]; /* The argument objects */
119
static char *berkdbcmds[] = {
132
/* All below are compatibility functions */
133
"hcreate", "hsearch", "hdestroy",
134
"dbminit", "fetch", "store",
135
"delete", "firstkey", "nextkey",
136
"ndbm_open", "dbmclose",
138
/* All below are convenience functions */
139
"rand", "random_int", "srand",
144
* All commands enums below ending in X are compatibility
159
BDB_HCREATEX, BDB_HSEARCHX, BDB_HDESTROYX,
160
BDB_DBMINITX, BDB_FETCHX, BDB_STOREX,
161
BDB_DELETEX, BDB_FIRSTKEYX, BDB_NEXTKEYX,
162
BDB_NDBMOPENX, BDB_DBMCLOSEX,
164
BDB_RANDX, BDB_RAND_INTX, BDB_SRANDX,
167
static int env_id = 0;
168
static int db_id = 0;
173
static int ndbm_id = 0;
178
int cmdindex, result;
179
char newname[MSG_SIZE];
181
COMPQUIET(notused, NULL);
183
Tcl_ResetResult(interp);
184
memset(newname, 0, MSG_SIZE);
187
Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
192
* Get the command name index from the object based on the berkdbcmds
195
if (Tcl_GetIndexFromObj(interp,
196
objv[1], berkdbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
197
return (IS_HELP(objv[1]));
199
switch ((enum berkdbcmds)cmdindex) {
202
result = bdb_DbVerify(interp, objc, objv);
205
result = bdb_Handles(interp, objc, objv);
208
result = bdb_DbUpgrade(interp, objc, objv);
213
result = bdb_Version(interp, objc, objv);
216
snprintf(newname, sizeof(newname), "env%d", env_id);
217
ip = _NewInfo(interp, NULL, newname, I_ENV);
219
result = bdb_EnvOpen(interp, objc, objv, ip, &envp);
220
if (result == TCL_OK && envp != NULL) {
222
Tcl_CreateObjCommand(interp, newname,
223
(Tcl_ObjCmdProc *)env_Cmd,
224
(ClientData)envp, NULL);
225
/* Use ip->i_name - newname is overwritten */
227
Tcl_NewStringObj(newname, strlen(newname));
228
_SetInfoData(ip, envp);
232
Tcl_SetResult(interp, "Could not set up info",
238
result = bdb_DbRemove(interp, objc, objv);
241
result = bdb_DbRename(interp, objc, objv);
244
result = tcl_EnvRemove(interp, objc, objv, NULL, NULL);
247
snprintf(newname, sizeof(newname), "db%d", db_id);
248
ip = _NewInfo(interp, NULL, newname, I_DB);
250
result = bdb_DbOpen(interp, objc, objv, ip, &dbp);
251
if (result == TCL_OK && dbp != NULL) {
253
Tcl_CreateObjCommand(interp, newname,
254
(Tcl_ObjCmdProc *)db_Cmd,
255
(ClientData)dbp, NULL);
256
/* Use ip->i_name - newname is overwritten */
258
Tcl_NewStringObj(newname, strlen(newname));
259
_SetInfoData(ip, dbp);
263
Tcl_SetResult(interp, "Could not set up info",
272
result = bdb_HCommand(interp, objc, objv);
281
result = bdb_DbmCommand(interp, objc, objv, DBTCL_DBM, NULL);
284
snprintf(newname, sizeof(newname), "ndbm%d", ndbm_id);
285
ip = _NewInfo(interp, NULL, newname, I_NDBM);
287
result = bdb_NdbmOpen(interp, objc, objv, &ndbmp);
288
if (result == TCL_OK) {
290
Tcl_CreateObjCommand(interp, newname,
291
(Tcl_ObjCmdProc *)ndbm_Cmd,
292
(ClientData)ndbmp, NULL);
293
/* Use ip->i_name - newname is overwritten */
295
Tcl_NewStringObj(newname, strlen(newname));
296
_SetInfoData(ip, ndbmp);
300
Tcl_SetResult(interp, "Could not set up info",
309
result = bdb_RandCommand(interp, objc, objv);
313
res = Tcl_NewIntObj(0);
317
* For each different arg call different function to create
318
* new commands (or if version, get/return it).
320
if (result == TCL_OK && res != NULL)
321
Tcl_SetObjResult(interp, res);
327
* Implements the environment open command.
328
* There are many, many options to the open command.
329
* Here is the general flow:
331
* 1. Call db_env_create to create the env handle.
332
* 2. Parse args tracking options.
333
* 3. Make any pre-open setup calls necessary.
334
* 4. Call DB_ENV->open to open the env.
335
* 5. Return env widget handle to user.
338
bdb_EnvOpen(interp, objc, objv, ip, env)
339
Tcl_Interp *interp; /* Interpreter */
340
int objc; /* How many arguments? */
341
Tcl_Obj *CONST objv[]; /* The argument objects */
342
DBTCL_INFO *ip; /* Our internal info */
343
DB_ENV **env; /* Environment pointer */
345
static char *envopen[] = {
402
* These have to be in the same order as the above,
403
* which is close to but not quite alphabetical.
416
ENV_LOCK_MAX_LOCKERS,
417
ENV_LOCK_MAX_OBJECTS,
459
Tcl_Obj **myobjv, **myobjv1;
461
u_int32_t detect, gbytes, bytes, ncaches, logbufset, logmaxset;
462
u_int32_t open_flags, rep_flags, set_flags, size, uintarg;
464
int i, intarg, j, mode, myobjc, nmodes, optindex;
465
int result, ret, temp;
466
long client_to, server_to, shm;
467
char *arg, *home, *passwd, *server;
471
rep_flags = set_flags = 0;
476
* If/when our Tcl interface becomes thread-safe, we should enable
477
* DB_THREAD here in all cases. For now, turn it on only when testing
478
* so that we exercise MUTEX_THREAD_LOCK cases.
480
* Historically, a key stumbling block was the log_get interface,
481
* which could only do relative operations in a non-threaded
482
* environment. This is no longer an issue, thanks to log cursors,
483
* but we need to look at making sure DBTCL_INFO structs
484
* are safe to share across threads (they're not mutex-protected)
485
* before we declare the Tcl interface thread-safe. Meanwhile,
486
* there's no strong reason to enable DB_THREAD.
488
open_flags = DB_JOINENV |
494
logmaxset = logbufset = 0;
497
Tcl_WrongNumArgs(interp, 2, objv, "?args?");
502
* Server code must go before the call to db_env_create.
505
server_to = client_to = 0;
508
if (Tcl_GetIndexFromObj(interp, objv[i++], envopen, "option",
509
TCL_EXACT, &optindex) != TCL_OK) {
510
Tcl_ResetResult(interp);
513
switch ((enum envopen)optindex) {
517
Tcl_WrongNumArgs(interp, 2, objv,
518
"?-server hostname");
522
server = Tcl_GetStringFromObj(objv[i++], NULL);
526
Tcl_WrongNumArgs(interp, 2, objv,
531
result = Tcl_GetLongFromObj(interp, objv[i++],
536
Tcl_WrongNumArgs(interp, 2, objv,
541
result = Tcl_GetLongFromObj(interp, objv[i++],
549
if (server != NULL) {
550
ret = db_env_create(env, DB_CLIENT);
552
return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
554
(*env)->set_errpfx((*env), ip->i_name);
555
(*env)->set_errcall((*env), _ErrorFunc);
556
if ((ret = (*env)->set_rpc_server((*env), NULL, server,
557
client_to, server_to, 0)) != 0) {
563
* Create the environment handle before parsing the args
564
* since we'll be modifying the environment as we parse.
566
ret = db_env_create(env, 0);
568
return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
570
(*env)->set_errpfx((*env), ip->i_name);
571
(*env)->set_errcall((*env), _ErrorFunc);
574
/* Hang our info pointer on the env handle, so we can do callbacks. */
575
(*env)->app_private = ip;
578
* Use a Tcl-local alloc and free function so that we're sure to
579
* test whether we use umalloc/ufree in the right places.
582
(*env)->set_alloc(*env, tcl_db_malloc, tcl_db_realloc, tcl_db_free);
586
* Get the command name index from the object based on the bdbcmds
591
Tcl_ResetResult(interp);
592
if (Tcl_GetIndexFromObj(interp, objv[i], envopen, "option",
593
TCL_EXACT, &optindex) != TCL_OK) {
594
result = IS_HELP(objv[i]);
598
switch ((enum envopen)optindex) {
604
* Already handled these, skip them and their arg.
608
case ENV_AUTO_COMMIT:
609
FLD_SET(set_flags, DB_AUTO_COMMIT);
612
FLD_SET(open_flags, DB_INIT_CDB | DB_INIT_MPOOL);
613
FLD_CLR(open_flags, DB_JOINENV);
616
FLD_SET(set_flags, DB_CDB_ALLDB);
619
FLD_SET(open_flags, DB_INIT_LOCK | DB_INIT_MPOOL);
620
FLD_CLR(open_flags, DB_JOINENV);
624
* Get conflict list. List is:
627
* Where matrix must be nmodes*nmodes big.
628
* Set up conflicts array to pass.
630
result = Tcl_ListObjGetElements(interp, objv[i],
632
if (result == TCL_OK)
637
Tcl_WrongNumArgs(interp, 2, objv,
638
"?-lock_conflict {nmodes {matrix}}?");
642
result = Tcl_GetIntFromObj(interp, myobjv[0], &nmodes);
643
if (result != TCL_OK)
645
result = Tcl_ListObjGetElements(interp, myobjv[1],
647
if (myobjc != (nmodes * nmodes)) {
648
Tcl_WrongNumArgs(interp, 2, objv,
649
"?-lock_conflict {nmodes {matrix}}?");
653
size = sizeof(u_int8_t) * nmodes*nmodes;
654
ret = __os_malloc(*env, size, &conflicts);
659
for (j = 0; j < myobjc; j++) {
660
result = Tcl_GetIntFromObj(interp, myobjv1[j],
663
if (result != TCL_OK) {
664
__os_free(NULL, conflicts);
669
ret = (*env)->set_lk_conflicts(*env,
670
(u_int8_t *)conflicts, nmodes);
671
__os_free(NULL, conflicts);
672
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
677
Tcl_WrongNumArgs(interp, 2, objv,
678
"?-lock_detect policy?");
682
arg = Tcl_GetStringFromObj(objv[i++], NULL);
683
if (strcmp(arg, "default") == 0)
684
detect = DB_LOCK_DEFAULT;
685
else if (strcmp(arg, "expire") == 0)
686
detect = DB_LOCK_EXPIRE;
687
else if (strcmp(arg, "maxlocks") == 0)
688
detect = DB_LOCK_MAXLOCKS;
689
else if (strcmp(arg, "minlocks") == 0)
690
detect = DB_LOCK_MINLOCKS;
691
else if (strcmp(arg, "minwrites") == 0)
692
detect = DB_LOCK_MINWRITE;
693
else if (strcmp(arg, "oldest") == 0)
694
detect = DB_LOCK_OLDEST;
695
else if (strcmp(arg, "youngest") == 0)
696
detect = DB_LOCK_YOUNGEST;
697
else if (strcmp(arg, "random") == 0)
698
detect = DB_LOCK_RANDOM;
700
Tcl_AddErrorInfo(interp,
701
"lock_detect: illegal policy");
706
ret = (*env)->set_lk_detect(*env, detect);
707
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
711
case ENV_LOCK_MAX_LOCKS:
712
case ENV_LOCK_MAX_LOCKERS:
713
case ENV_LOCK_MAX_OBJECTS:
715
Tcl_WrongNumArgs(interp, 2, objv,
720
result = _GetUInt32(interp, objv[i++], &uintarg);
721
if (result == TCL_OK) {
723
switch ((enum envopen)optindex) {
725
ret = (*env)->set_lk_max(*env,
728
case ENV_LOCK_MAX_LOCKS:
729
ret = (*env)->set_lk_max_locks(*env,
732
case ENV_LOCK_MAX_LOCKERS:
733
ret = (*env)->set_lk_max_lockers(*env,
736
case ENV_LOCK_MAX_OBJECTS:
737
ret = (*env)->set_lk_max_objects(*env,
743
result = _ReturnSetup(interp, ret,
744
DB_RETOK_STD(ret), "lock_max");
748
case ENV_TXN_TIMEOUT:
749
case ENV_LOCK_TIMEOUT:
751
Tcl_WrongNumArgs(interp, 2, objv,
752
"?-txn_timestamp time?");
756
result = Tcl_GetLongFromObj(interp, objv[i++],
758
if (result == TCL_OK) {
760
if (optindex == ENV_TXN_TIME)
762
set_tx_timestamp(*env, ×tamp);
764
ret = (*env)->set_timeout(*env,
765
(db_timeout_t)timestamp,
766
optindex == ENV_TXN_TIMEOUT ?
768
DB_SET_LOCK_TIMEOUT);
769
result = _ReturnSetup(interp, ret,
770
DB_RETOK_STD(ret), "txn_timestamp");
774
FLD_SET(open_flags, DB_INIT_LOG | DB_INIT_MPOOL);
775
FLD_CLR(open_flags, DB_JOINENV);
779
Tcl_WrongNumArgs(interp, 2, objv,
780
"?-log_buffer size?");
784
result = _GetUInt32(interp, objv[i++], &uintarg);
785
if (result == TCL_OK) {
787
ret = (*env)->set_lg_bsize(*env, uintarg);
788
result = _ReturnSetup(interp, ret,
789
DB_RETOK_STD(ret), "log_bsize");
793
ret = (*env)->set_lg_max(*env,
795
result = _ReturnSetup(interp, ret,
796
DB_RETOK_STD(ret), "log_max");
804
Tcl_WrongNumArgs(interp, 2, objv,
809
result = _GetUInt32(interp, objv[i++], &uintarg);
810
if (result == TCL_OK && logbufset) {
812
ret = (*env)->set_lg_max(*env, uintarg);
813
result = _ReturnSetup(interp, ret,
814
DB_RETOK_STD(ret), "log_max");
819
case ENV_LOG_REGIONMAX:
821
Tcl_WrongNumArgs(interp, 2, objv,
822
"?-log_regionmax size?");
826
result = _GetUInt32(interp, objv[i++], &uintarg);
827
if (result == TCL_OK) {
829
ret = (*env)->set_lg_regionmax(*env, uintarg);
831
_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
837
Tcl_WrongNumArgs(interp, 2, objv,
842
result = Tcl_GetIntFromObj(interp, objv[i++], &intarg);
843
if (result == TCL_OK) {
845
ret = (*env)->set_mp_mmapsize(*env,
847
result = _ReturnSetup(interp, ret,
848
DB_RETOK_STD(ret), "mmapsize");
852
FLD_SET(set_flags, DB_NOMMAP);
855
FLD_SET(set_flags, DB_OVERWRITE);
857
case ENV_REGION_INIT:
859
ret = (*env)->set_flags(*env, DB_REGION_INIT, 1);
860
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
864
rep_flags = DB_REP_CLIENT;
866
case ENV_REP_LOGSONLY:
867
rep_flags = DB_REP_LOGSONLY;
870
rep_flags = DB_REP_MASTER;
872
case ENV_REP_TRANSPORT:
874
Tcl_WrongNumArgs(interp, 2, objv,
875
"-rep_transport {envid sendproc}");
881
* Store the objects containing the machine ID
882
* and the procedure name. We don't need to crack
883
* the send procedure out now, but we do convert the
884
* machine ID to an int, since set_rep_transport needs
885
* it. Even so, it'll be easier later to deal with
886
* the Tcl_Obj *, so we save that, not the int.
888
* Note that we Tcl_IncrRefCount both objects
889
* independently; Tcl is free to discard the list
890
* that they're bundled into.
892
result = Tcl_ListObjGetElements(interp, objv[i++],
895
Tcl_SetResult(interp,
896
"List must be {envid sendproc}",
903
* Check that the machine ID is an int. Note that
904
* we do want to use GetIntFromObj; the machine
905
* ID is explicitly an int, not a u_int32_t.
907
ip->i_rep_eid = myobjv[0];
908
Tcl_IncrRefCount(ip->i_rep_eid);
909
result = Tcl_GetIntFromObj(interp,
910
ip->i_rep_eid, &intarg);
911
if (result != TCL_OK)
914
ip->i_rep_send = myobjv[1];
915
Tcl_IncrRefCount(ip->i_rep_send);
917
ret = (*env)->set_rep_transport(*env,
918
intarg, tcl_rep_send);
919
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
920
"set_rep_transport");
923
result = Tcl_ListObjGetElements(interp, objv[i],
925
if (result == TCL_OK)
930
Tcl_WrongNumArgs(interp, 2, objv,
931
"?-verbose {which on|off}?");
935
result = tcl_EnvVerbose(interp, *env,
936
myobjv[0], myobjv[1]);
939
FLD_SET(set_flags, DB_TXN_WRITE_NOSYNC);
943
FLD_SET(open_flags, DB_INIT_LOCK |
944
DB_INIT_LOG | DB_INIT_MPOOL | DB_INIT_TXN);
945
FLD_CLR(open_flags, DB_JOINENV);
946
/* Make sure we have an arg to check against! */
948
arg = Tcl_GetStringFromObj(objv[i], NULL);
949
if (strcmp(arg, "nosync") == 0) {
950
FLD_SET(set_flags, DB_TXN_NOSYNC);
956
FLD_SET(open_flags, DB_CREATE | DB_INIT_MPOOL);
957
FLD_CLR(open_flags, DB_JOINENV);
959
case ENV_ENCRYPT_AES:
960
/* Make sure we have an arg to check against! */
962
Tcl_WrongNumArgs(interp, 2, objv,
963
"?-encryptaes passwd?");
967
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
969
ret = (*env)->set_encrypt(*env, passwd, DB_ENCRYPT_AES);
970
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
973
case ENV_ENCRYPT_ANY:
974
/* Make sure we have an arg to check against! */
976
Tcl_WrongNumArgs(interp, 2, objv,
977
"?-encryptany passwd?");
981
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
983
ret = (*env)->set_encrypt(*env, passwd, 0);
984
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
988
/* Make sure we have an arg to check against! */
990
Tcl_WrongNumArgs(interp, 2, objv,
995
home = Tcl_GetStringFromObj(objv[i++], NULL);
999
Tcl_WrongNumArgs(interp, 2, objv,
1005
* Don't need to check result here because
1006
* if TCL_ERROR, the error message is already
1007
* set up, and we'll bail out below. If ok,
1008
* the mode is set and we go on.
1010
result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
1013
FLD_SET(open_flags, DB_PRIVATE | DB_INIT_MPOOL);
1014
FLD_CLR(open_flags, DB_JOINENV);
1017
FLD_SET(open_flags, DB_RECOVER);
1019
case ENV_RECOVER_FATAL:
1020
FLD_SET(open_flags, DB_RECOVER_FATAL);
1022
case ENV_SYSTEM_MEM:
1023
FLD_SET(open_flags, DB_SYSTEM_MEM);
1025
case ENV_USE_ENVIRON_ROOT:
1026
FLD_SET(open_flags, DB_USE_ENVIRON_ROOT);
1028
case ENV_USE_ENVIRON:
1029
FLD_SET(open_flags, DB_USE_ENVIRON);
1032
result = Tcl_ListObjGetElements(interp, objv[i],
1034
if (result == TCL_OK)
1039
Tcl_WrongNumArgs(interp, 2, objv,
1040
"?-cachesize {gbytes bytes ncaches}?");
1044
result = _GetUInt32(interp, myobjv[0], &gbytes);
1045
if (result != TCL_OK)
1047
result = _GetUInt32(interp, myobjv[1], &bytes);
1048
if (result != TCL_OK)
1050
result = _GetUInt32(interp, myobjv[2], &ncaches);
1051
if (result != TCL_OK)
1054
ret = (*env)->set_cachesize(*env, gbytes, bytes,
1056
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1061
Tcl_WrongNumArgs(interp, 2, objv,
1066
result = Tcl_GetLongFromObj(interp, objv[i++], &shm);
1067
if (result == TCL_OK) {
1069
ret = (*env)->set_shm_key(*env, shm);
1070
result = _ReturnSetup(interp, ret,
1071
DB_RETOK_STD(ret), "shm_key");
1076
Tcl_WrongNumArgs(interp, 2, objv,
1081
result = _GetUInt32(interp, objv[i++], &uintarg);
1082
if (result == TCL_OK) {
1084
ret = (*env)->set_tx_max(*env, uintarg);
1085
result = _ReturnSetup(interp, ret,
1086
DB_RETOK_STD(ret), "txn_max");
1091
Tcl_WrongNumArgs(interp, 2, objv,
1096
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1098
* If the user already set one, close it.
1100
if (ip->i_err != NULL)
1102
ip->i_err = fopen(arg, "a");
1103
if (ip->i_err != NULL) {
1105
(*env)->set_errfile(*env, ip->i_err);
1110
Tcl_WrongNumArgs(interp, 2, objv,
1115
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1117
* If the user already set one, free it.
1119
if (ip->i_errpfx != NULL)
1120
__os_free(NULL, ip->i_errpfx);
1122
__os_strdup(*env, arg, &ip->i_errpfx)) != 0) {
1123
result = _ReturnSetup(interp, ret,
1124
DB_RETOK_STD(ret), "__os_strdup");
1127
if (ip->i_errpfx != NULL) {
1129
(*env)->set_errpfx(*env, ip->i_errpfx);
1134
Tcl_WrongNumArgs(interp, 2, objv,
1139
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1141
ret = (*env)->set_data_dir(*env, arg);
1142
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1147
Tcl_WrongNumArgs(interp, 2, objv,
1152
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1154
ret = (*env)->set_lg_dir(*env, arg);
1155
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1160
Tcl_WrongNumArgs(interp, 2, objv,
1165
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1167
ret = (*env)->set_tmp_dir(*env, arg);
1168
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1173
* If, at any time, parsing the args we get an error,
1174
* bail out and return.
1176
if (result != TCL_OK)
1181
* We have to check this here. We want to set the log buffer
1182
* size first, if it is specified. So if the user did so,
1183
* then we took care of it above. But, if we get out here and
1184
* logmaxset is non-zero, then they set the log_max without
1185
* resetting the log buffer size, so we now have to do the
1186
* call to set_lg_max, since we didn't do it above.
1190
ret = (*env)->set_lg_max(*env, (u_int32_t)logmaxset);
1191
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1195
if (result != TCL_OK)
1199
ret = (*env)->set_flags(*env, set_flags, 1);
1200
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1202
if (result == TCL_ERROR)
1205
* If we are successful, clear the result so that the
1206
* return from set_flags isn't part of the result.
1208
Tcl_ResetResult(interp);
1211
* When we get here, we have already parsed all of our args
1212
* and made all our calls to set up the environment. Everything
1213
* is okay so far, no errors, if we get here.
1215
* Now open the environment.
1218
ret = (*env)->open(*env, home, open_flags, mode);
1219
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "env open");
1221
if (rep_flags != 0 && result == TCL_OK) {
1223
ret = (*env)->rep_start(*env, NULL, rep_flags);
1224
result = _ReturnSetup(interp,
1225
ret, DB_RETOK_STD(ret), "rep_start");
1228
error: if (result == TCL_ERROR) {
1233
(void)(*env)->close(*env, 0);
1241
* Implements the "db_create/db_open" command.
1242
* There are many, many options to the open command.
1243
* Here is the general flow:
1245
* 0. Preparse args to determine if we have -env.
1246
* 1. Call db_create to create the db handle.
1247
* 2. Parse args tracking options.
1248
* 3. Make any pre-open setup calls necessary.
1249
* 4. Call DB->open to open the database.
1250
* 5. Return db widget handle to user.
1253
bdb_DbOpen(interp, objc, objv, ip, dbp)
1254
Tcl_Interp *interp; /* Interpreter */
1255
int objc; /* How many arguments? */
1256
Tcl_Obj *CONST objv[]; /* The argument objects */
1257
DBTCL_INFO *ip; /* Our internal info */
1258
DB **dbp; /* DB handle */
1260
static char *bdbenvopen[] = {
1266
static char *bdbopen[] = {
1362
DBTCL_INFO *envip, *errip;
1367
u_int32_t gbytes, bytes, ncaches, open_flags, uintarg;
1368
int endarg, i, intarg, mode, myobjc;
1369
int optindex, result, ret, set_err, set_flags, set_pfx, subdblen;
1371
char *arg, *db, *passwd, *subdb, msg[MSG_SIZE];
1374
endarg = mode = set_err = set_flags = set_pfx = 0;
1381
* If/when our Tcl interface becomes thread-safe, we should enable
1382
* DB_THREAD here in all cases. See comment in bdb_EnvOpen().
1383
* For now, just turn it on when testing so that we exercise
1384
* MUTEX_THREAD_LOCK cases.
1396
Tcl_WrongNumArgs(interp, 2, objv, "?args?");
1401
* We must first parse for the environment flag, since that
1402
* is needed for db_create. Then create the db handle.
1406
if (Tcl_GetIndexFromObj(interp, objv[i++], bdbenvopen,
1407
"option", TCL_EXACT, &optindex) != TCL_OK) {
1409
* Reset the result so we don't get
1410
* an errant error message if there is another error.
1412
Tcl_ResetResult(interp);
1415
switch ((enum bdbenvopen)optindex) {
1417
arg = Tcl_GetStringFromObj(objv[i], NULL);
1418
envp = NAME_TO_ENV(arg);
1420
Tcl_SetResult(interp,
1421
"db open: illegal environment", TCL_STATIC);
1429
* Create the db handle before parsing the args
1430
* since we'll be modifying the database options as we parse.
1432
ret = db_create(dbp, envp, 0);
1434
return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1437
/* Hang our info pointer on the DB handle, so we can do callbacks. */
1438
(*dbp)->api_internal = ip;
1441
* XXX Remove restriction when err stuff is not tied to env.
1443
* The DB->set_err* functions actually overwrite in the
1444
* environment. So, if we are explicitly using an env,
1445
* don't overwrite what we have already set up. If we are
1446
* not using one, then we set up since we get a private
1449
/* XXX - remove this conditional if/when err is not tied to env */
1451
(*dbp)->set_errpfx((*dbp), ip->i_name);
1452
(*dbp)->set_errcall((*dbp), _ErrorFunc);
1454
envip = _PtrToInfo(envp); /* XXX */
1456
* If we are using an env, we keep track of err info in the env's ip.
1457
* Otherwise use the DB's ip.
1464
* Get the option name index from the object based on the args
1469
Tcl_ResetResult(interp);
1470
if (Tcl_GetIndexFromObj(interp, objv[i], bdbopen, "option",
1471
TCL_EXACT, &optindex) != TCL_OK) {
1472
arg = Tcl_GetStringFromObj(objv[i], NULL);
1473
if (arg[0] == '-') {
1474
result = IS_HELP(objv[i]);
1477
Tcl_ResetResult(interp);
1481
switch ((enum bdbopen)optindex) {
1483
case TCL_DB_BTCOMPARE:
1485
Tcl_WrongNumArgs(interp, 2, objv,
1486
"-btcompare compareproc");
1492
* Store the object containing the procedure name.
1493
* We don't need to crack it out now--we'll want
1494
* to bundle it up to pass into Tcl_EvalObjv anyway.
1495
* Tcl's object refcounting will--I hope--take care
1496
* of the memory management here.
1498
ip->i_btcompare = objv[i++];
1499
Tcl_IncrRefCount(ip->i_btcompare);
1501
ret = (*dbp)->set_bt_compare(*dbp, tcl_bt_compare);
1502
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1506
open_flags |= DB_DIRTY_READ;
1508
case TCL_DB_DUPCOMPARE:
1510
Tcl_WrongNumArgs(interp, 2, objv,
1511
"-dupcompare compareproc");
1517
* Store the object containing the procedure name.
1518
* See TCL_DB_BTCOMPARE.
1520
ip->i_dupcompare = objv[i++];
1521
Tcl_IncrRefCount(ip->i_dupcompare);
1523
ret = (*dbp)->set_dup_compare(*dbp, tcl_dup_compare);
1524
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1527
case TCL_DB_HASHPROC:
1529
Tcl_WrongNumArgs(interp, 2, objv,
1530
"-hashproc hashproc");
1536
* Store the object containing the procedure name.
1537
* See TCL_DB_BTCOMPARE.
1539
ip->i_hashproc = objv[i++];
1540
Tcl_IncrRefCount(ip->i_hashproc);
1542
ret = (*dbp)->set_h_hash(*dbp, tcl_h_hash);
1543
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1548
Tcl_WrongNumArgs(interp, 2, objv,
1549
"-lorder 1234|4321");
1553
result = _GetUInt32(interp, objv[i++], &uintarg);
1554
if (result == TCL_OK) {
1556
ret = (*dbp)->set_lorder(*dbp, uintarg);
1557
result = _ReturnSetup(interp, ret,
1558
DB_RETOK_STD(ret), "set_lorder");
1563
Tcl_WrongNumArgs(interp, 2, objv,
1568
result = _GetUInt32(interp, objv[i++], &uintarg);
1569
if (result == TCL_OK) {
1571
ret = (*dbp)->set_bt_minkey(*dbp, uintarg);
1572
result = _ReturnSetup(interp, ret,
1573
DB_RETOK_STD(ret), "set_bt_minkey");
1577
open_flags |= DB_NOMMAP;
1579
case TCL_DB_REVSPLIT:
1580
set_flags |= DB_REVSPLITOFF;
1583
(*dbp)->set_h_hash(*dbp, __ham_test);
1586
case TCL_DB_AUTO_COMMIT:
1587
open_flags |= DB_AUTO_COMMIT;
1591
* Already parsed this, skip it and the env pointer.
1596
if (i > (objc - 1)) {
1597
Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
1601
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1602
txn = NAME_TO_TXN(arg);
1604
snprintf(msg, MSG_SIZE,
1605
"Put: Invalid txn: %s\n", arg);
1606
Tcl_SetResult(interp, msg, TCL_VOLATILE);
1611
if (type != DB_UNKNOWN) {
1612
Tcl_SetResult(interp,
1613
"Too many DB types specified", TCL_STATIC);
1620
if (type != DB_UNKNOWN) {
1621
Tcl_SetResult(interp,
1622
"Too many DB types specified", TCL_STATIC);
1629
if (type != DB_UNKNOWN) {
1630
Tcl_SetResult(interp,
1631
"Too many DB types specified", TCL_STATIC);
1638
if (type != DB_UNKNOWN) {
1639
Tcl_SetResult(interp,
1640
"Too many DB types specified", TCL_STATIC);
1646
case TCL_DB_UNKNOWN:
1647
if (type != DB_UNKNOWN) {
1648
Tcl_SetResult(interp,
1649
"Too many DB types specified", TCL_STATIC);
1655
open_flags |= DB_CREATE;
1658
open_flags |= DB_EXCL;
1661
open_flags |= DB_RDONLY;
1663
case TCL_DB_TRUNCATE:
1664
open_flags |= DB_TRUNCATE;
1668
Tcl_WrongNumArgs(interp, 2, objv,
1674
* Don't need to check result here because
1675
* if TCL_ERROR, the error message is already
1676
* set up, and we'll bail out below. If ok,
1677
* the mode is set and we go on.
1679
result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
1682
set_flags |= DB_DUP;
1684
case TCL_DB_DUPSORT:
1685
set_flags |= DB_DUPSORT;
1688
set_flags |= DB_RECNUM;
1690
case TCL_DB_RENUMBER:
1691
set_flags |= DB_RENUMBER;
1693
case TCL_DB_SNAPSHOT:
1694
set_flags |= DB_SNAPSHOT;
1697
set_flags |= DB_CHKSUM_SHA1;
1699
case TCL_DB_ENCRYPT:
1700
set_flags |= DB_ENCRYPT;
1702
case TCL_DB_ENCRYPT_AES:
1703
/* Make sure we have an arg to check against! */
1705
Tcl_WrongNumArgs(interp, 2, objv,
1706
"?-encryptaes passwd?");
1710
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
1712
ret = (*dbp)->set_encrypt(*dbp, passwd, DB_ENCRYPT_AES);
1713
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1716
case TCL_DB_ENCRYPT_ANY:
1717
/* Make sure we have an arg to check against! */
1719
Tcl_WrongNumArgs(interp, 2, objv,
1720
"?-encryptany passwd?");
1724
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
1726
ret = (*dbp)->set_encrypt(*dbp, passwd, 0);
1727
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1730
case TCL_DB_FFACTOR:
1732
Tcl_WrongNumArgs(interp, 2, objv,
1733
"-ffactor density");
1737
result = _GetUInt32(interp, objv[i++], &uintarg);
1738
if (result == TCL_OK) {
1740
ret = (*dbp)->set_h_ffactor(*dbp, uintarg);
1741
result = _ReturnSetup(interp, ret,
1742
DB_RETOK_STD(ret), "set_h_ffactor");
1747
Tcl_WrongNumArgs(interp, 2, objv,
1752
result = _GetUInt32(interp, objv[i++], &uintarg);
1753
if (result == TCL_OK) {
1755
ret = (*dbp)->set_h_nelem(*dbp, uintarg);
1756
result = _ReturnSetup(interp, ret,
1757
DB_RETOK_STD(ret), "set_h_nelem");
1762
Tcl_WrongNumArgs(interp, 2, objv,
1767
result = Tcl_GetIntFromObj(interp, objv[i++], &intarg);
1768
if (result == TCL_OK) {
1770
ret = (*dbp)->set_re_delim(*dbp, intarg);
1771
result = _ReturnSetup(interp, ret,
1772
DB_RETOK_STD(ret), "set_re_delim");
1777
Tcl_WrongNumArgs(interp, 2, objv,
1782
result = _GetUInt32(interp, objv[i++], &uintarg);
1783
if (result == TCL_OK) {
1785
ret = (*dbp)->set_re_len(*dbp, uintarg);
1786
result = _ReturnSetup(interp, ret,
1787
DB_RETOK_STD(ret), "set_re_len");
1792
Tcl_WrongNumArgs(interp, 2, objv,
1797
result = Tcl_GetIntFromObj(interp, objv[i++], &intarg);
1798
if (result == TCL_OK) {
1800
ret = (*dbp)->set_re_pad(*dbp, intarg);
1801
result = _ReturnSetup(interp, ret,
1802
DB_RETOK_STD(ret), "set_re_pad");
1807
Tcl_WrongNumArgs(interp, 2, objv,
1812
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1814
ret = (*dbp)->set_re_source(*dbp, arg);
1815
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1820
Tcl_WrongNumArgs(interp, 2, objv,
1825
result = _GetUInt32(interp, objv[i++], &uintarg);
1826
if (result == TCL_OK) {
1828
ret = (*dbp)->set_q_extentsize(*dbp, uintarg);
1829
result = _ReturnSetup(interp, ret,
1830
DB_RETOK_STD(ret), "set_q_extentsize");
1833
case TCL_DB_CACHESIZE:
1834
result = Tcl_ListObjGetElements(interp, objv[i++],
1836
if (result != TCL_OK)
1839
Tcl_WrongNumArgs(interp, 2, objv,
1840
"?-cachesize {gbytes bytes ncaches}?");
1844
result = _GetUInt32(interp, myobjv[0], &gbytes);
1845
if (result != TCL_OK)
1847
result = _GetUInt32(interp, myobjv[1], &bytes);
1848
if (result != TCL_OK)
1850
result = _GetUInt32(interp, myobjv[2], &ncaches);
1851
if (result != TCL_OK)
1854
ret = (*dbp)->set_cachesize(*dbp, gbytes, bytes,
1856
result = _ReturnSetup(interp, ret,
1857
DB_RETOK_STD(ret), "set_cachesize");
1859
case TCL_DB_PAGESIZE:
1861
Tcl_WrongNumArgs(interp, 2, objv,
1862
"?-pagesize size?");
1866
result = Tcl_GetIntFromObj(interp, objv[i++], &intarg);
1867
if (result == TCL_OK) {
1869
ret = (*dbp)->set_pagesize(*dbp,
1871
result = _ReturnSetup(interp, ret,
1872
DB_RETOK_STD(ret), "set pagesize");
1875
case TCL_DB_ERRFILE:
1877
Tcl_WrongNumArgs(interp, 2, objv,
1882
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1884
* If the user already set one, close it.
1886
if (errip->i_err != NULL)
1887
fclose(errip->i_err);
1888
errip->i_err = fopen(arg, "a");
1889
if (errip->i_err != NULL) {
1891
(*dbp)->set_errfile(*dbp, errip->i_err);
1897
Tcl_WrongNumArgs(interp, 2, objv,
1902
arg = Tcl_GetStringFromObj(objv[i++], NULL);
1904
* If the user already set one, free it.
1906
if (errip->i_errpfx != NULL)
1907
__os_free(NULL, errip->i_errpfx);
1908
if ((ret = __os_strdup((*dbp)->dbenv,
1909
arg, &errip->i_errpfx)) != 0) {
1910
result = _ReturnSetup(interp, ret,
1911
DB_RETOK_STD(ret), "__os_strdup");
1914
if (errip->i_errpfx != NULL) {
1916
(*dbp)->set_errpfx(*dbp, errip->i_errpfx);
1926
* If, at any time, parsing the args we get an error,
1927
* bail out and return.
1929
if (result != TCL_OK)
1934
if (result != TCL_OK)
1938
* Any args we have left, (better be 0, 1 or 2 left) are
1939
* file names. If we have 0, then an in-memory db. If
1940
* there is 1, a db name, if 2 a db and subdb name.
1944
* Dbs must be NULL terminated file names, but subdbs can
1945
* be anything. Use Strings for the db name and byte
1946
* arrays for the subdb.
1948
db = Tcl_GetStringFromObj(objv[i++], NULL);
1951
Tcl_GetByteArrayFromObj(objv[i++], &subdblen);
1952
if ((ret = __os_malloc(envp,
1953
subdblen + 1, &subdb)) != 0) {
1954
Tcl_SetResult(interp, db_strerror(ret),
1958
memcpy(subdb, subdbtmp, subdblen);
1959
subdb[subdblen] = '\0';
1963
ret = (*dbp)->set_flags(*dbp, set_flags);
1964
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
1966
if (result == TCL_ERROR)
1969
* If we are successful, clear the result so that the
1970
* return from set_flags isn't part of the result.
1972
Tcl_ResetResult(interp);
1976
* When we get here, we have already parsed all of our args and made
1977
* all our calls to set up the database. Everything is okay so far,
1978
* no errors, if we get here.
1982
/* Open the database. */
1983
ret = (*dbp)->open(*dbp, txn, db, subdb, type, open_flags, mode);
1984
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db open");
1988
__os_free(envp, subdb);
1989
if (result == TCL_ERROR) {
1990
(void)(*dbp)->close(*dbp, 0);
1992
* If we opened and set up the error file in the environment
1993
* on this open, but we failed for some other reason, clean
1994
* up and close the file.
1996
* XXX when err stuff isn't tied to env, change to use ip,
1997
* instead of envip. Also, set_err is irrelevant when that
1998
* happens. It will just read:
2000
* fclose(ip->i_err);
2002
if (set_err && errip && errip->i_err != NULL) {
2003
fclose(errip->i_err);
2004
errip->i_err = NULL;
2006
if (set_pfx && errip && errip->i_errpfx != NULL) {
2007
__os_free(envp, errip->i_errpfx);
2008
errip->i_errpfx = NULL;
2017
* Implements the DB_ENV->remove and DB->remove command.
2020
bdb_DbRemove(interp, objc, objv)
2021
Tcl_Interp *interp; /* Interpreter */
2022
int objc; /* How many arguments? */
2023
Tcl_Obj *CONST objv[]; /* The argument objects */
2025
static char *bdbrem[] = {
2036
TCL_DBREM_AUTOCOMMIT,
2038
TCL_DBREM_ENCRYPT_AES,
2039
TCL_DBREM_ENCRYPT_ANY,
2047
int endarg, i, optindex, result, ret, subdblen;
2048
u_int32_t enc_flag, iflags, set_flags;
2050
char *arg, *db, msg[MSG_SIZE], *passwd, *subdb;
2056
iflags = enc_flag = set_flags = 0;
2063
Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?");
2068
* We must first parse for the environment flag, since that
2069
* is needed for db_create. Then create the db handle.
2073
if (Tcl_GetIndexFromObj(interp, objv[i], bdbrem,
2074
"option", TCL_EXACT, &optindex) != TCL_OK) {
2075
arg = Tcl_GetStringFromObj(objv[i], NULL);
2076
if (arg[0] == '-') {
2077
result = IS_HELP(objv[i]);
2080
Tcl_ResetResult(interp);
2084
switch ((enum bdbrem)optindex) {
2085
case TCL_DBREM_AUTOCOMMIT:
2086
iflags |= DB_AUTO_COMMIT;
2089
case TCL_DBREM_ENCRYPT:
2090
set_flags |= DB_ENCRYPT;
2093
case TCL_DBREM_ENCRYPT_AES:
2094
/* Make sure we have an arg to check against! */
2096
Tcl_WrongNumArgs(interp, 2, objv,
2097
"?-encryptaes passwd?");
2101
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
2102
enc_flag = DB_ENCRYPT_AES;
2104
case TCL_DBREM_ENCRYPT_ANY:
2105
/* Make sure we have an arg to check against! */
2107
Tcl_WrongNumArgs(interp, 2, objv,
2108
"?-encryptany passwd?");
2112
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
2116
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2117
envp = NAME_TO_ENV(arg);
2119
Tcl_SetResult(interp,
2120
"db remove: illegal environment",
2125
case TCL_DBREM_ENDARG:
2130
Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
2134
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2135
txn = NAME_TO_TXN(arg);
2137
snprintf(msg, MSG_SIZE,
2138
"Put: Invalid txn: %s\n", arg);
2139
Tcl_SetResult(interp, msg, TCL_VOLATILE);
2145
* If, at any time, parsing the args we get an error,
2146
* bail out and return.
2148
if (result != TCL_OK)
2153
if (result != TCL_OK)
2156
* Any args we have left, (better be 1 or 2 left) are
2157
* file names. If there is 1, a db name, if 2 a db and subdb name.
2159
if ((i != (objc - 1)) || (i != (objc - 2))) {
2161
* Dbs must be NULL terminated file names, but subdbs can
2162
* be anything. Use Strings for the db name and byte
2163
* arrays for the subdb.
2165
db = Tcl_GetStringFromObj(objv[i++], NULL);
2168
Tcl_GetByteArrayFromObj(objv[i++], &subdblen);
2169
if ((ret = __os_malloc(envp, subdblen + 1,
2170
&subdb)) != 0) { Tcl_SetResult(interp,
2171
db_strerror(ret), TCL_STATIC);
2174
memcpy(subdb, subdbtmp, subdblen);
2175
subdb[subdblen] = '\0';
2178
Tcl_WrongNumArgs(interp, 2, objv, "?args? filename ?database?");
2183
ret = db_create(&dbp, envp, 0);
2185
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2190
if (passwd != NULL) {
2191
ret = dbp->set_encrypt(dbp, passwd, enc_flag);
2192
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2195
if (set_flags != 0) {
2196
ret = dbp->set_flags(dbp, set_flags);
2197
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2203
* No matter what, we NULL out dbp after this call.
2207
ret = envp->dbremove(envp, txn, db, subdb, iflags);
2209
ret = dbp->remove(dbp, db, subdb, 0);
2211
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db remove");
2215
__os_free(envp, subdb);
2216
if (result == TCL_ERROR && dbp != NULL)
2217
(void)dbp->close(dbp, 0);
2223
* Implements the DBENV->dbrename and DB->rename commands.
2226
bdb_DbRename(interp, objc, objv)
2227
Tcl_Interp *interp; /* Interpreter */
2228
int objc; /* How many arguments? */
2229
Tcl_Obj *CONST objv[]; /* The argument objects */
2231
static char *bdbmv[] = {
2242
TCL_DBMV_AUTOCOMMIT,
2244
TCL_DBMV_ENCRYPT_AES,
2245
TCL_DBMV_ENCRYPT_ANY,
2253
u_int32_t enc_flag, iflags, set_flags;
2254
int endarg, i, newlen, optindex, result, ret, subdblen;
2256
char *arg, *db, msg[MSG_SIZE], *newname, *passwd, *subdb;
2258
db = newname = subdb = NULL;
2262
iflags = enc_flag = set_flags = 0;
2269
Tcl_WrongNumArgs(interp,
2270
3, objv, "?args? filename ?database? ?newname?");
2275
* We must first parse for the environment flag, since that
2276
* is needed for db_create. Then create the db handle.
2280
if (Tcl_GetIndexFromObj(interp, objv[i], bdbmv,
2281
"option", TCL_EXACT, &optindex) != TCL_OK) {
2282
arg = Tcl_GetStringFromObj(objv[i], NULL);
2283
if (arg[0] == '-') {
2284
result = IS_HELP(objv[i]);
2287
Tcl_ResetResult(interp);
2291
switch ((enum bdbmv)optindex) {
2292
case TCL_DBMV_AUTOCOMMIT:
2293
iflags |= DB_AUTO_COMMIT;
2296
case TCL_DBMV_ENCRYPT:
2297
set_flags |= DB_ENCRYPT;
2300
case TCL_DBMV_ENCRYPT_AES:
2301
/* Make sure we have an arg to check against! */
2303
Tcl_WrongNumArgs(interp, 2, objv,
2304
"?-encryptaes passwd?");
2308
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
2309
enc_flag = DB_ENCRYPT_AES;
2311
case TCL_DBMV_ENCRYPT_ANY:
2312
/* Make sure we have an arg to check against! */
2314
Tcl_WrongNumArgs(interp, 2, objv,
2315
"?-encryptany passwd?");
2319
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
2323
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2324
envp = NAME_TO_ENV(arg);
2326
Tcl_SetResult(interp,
2327
"db rename: illegal environment",
2332
case TCL_DBMV_ENDARG:
2337
Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
2341
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2342
txn = NAME_TO_TXN(arg);
2344
snprintf(msg, MSG_SIZE,
2345
"Put: Invalid txn: %s\n", arg);
2346
Tcl_SetResult(interp, msg, TCL_VOLATILE);
2352
* If, at any time, parsing the args we get an error,
2353
* bail out and return.
2355
if (result != TCL_OK)
2360
if (result != TCL_OK)
2363
* Any args we have left, (better be 2 or 3 left) are
2364
* file names. If there is 2, a file name, if 3 a file and db name.
2366
if ((i != (objc - 2)) || (i != (objc - 3))) {
2368
* Dbs must be NULL terminated file names, but subdbs can
2369
* be anything. Use Strings for the db name and byte
2370
* arrays for the subdb.
2372
db = Tcl_GetStringFromObj(objv[i++], NULL);
2373
if (i == objc - 2) {
2375
Tcl_GetByteArrayFromObj(objv[i++], &subdblen);
2376
if ((ret = __os_malloc(envp, subdblen + 1,
2378
Tcl_SetResult(interp,
2379
db_strerror(ret), TCL_STATIC);
2382
memcpy(subdb, subdbtmp, subdblen);
2383
subdb[subdblen] = '\0';
2386
Tcl_GetByteArrayFromObj(objv[i++], &newlen);
2387
if ((ret = __os_malloc(envp, newlen + 1,
2389
Tcl_SetResult(interp,
2390
db_strerror(ret), TCL_STATIC);
2393
memcpy(newname, subdbtmp, newlen);
2394
newname[newlen] = '\0';
2397
interp, 3, objv, "?args? filename ?database? ?newname?");
2402
ret = db_create(&dbp, envp, 0);
2404
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2408
if (passwd != NULL) {
2409
ret = dbp->set_encrypt(dbp, passwd, enc_flag);
2410
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2413
if (set_flags != 0) {
2414
ret = dbp->set_flags(dbp, set_flags);
2415
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2421
* No matter what, we NULL out dbp after this call.
2424
ret = envp->dbrename(envp, txn, db, subdb, newname, iflags);
2426
ret = dbp->rename(dbp, db, subdb, newname, 0);
2427
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db rename");
2431
__os_free(envp, subdb);
2433
__os_free(envp, newname);
2434
if (result == TCL_ERROR && dbp != NULL)
2435
(void)dbp->close(dbp, 0);
2442
* Implements the DB->verify command.
2445
bdb_DbVerify(interp, objc, objv)
2446
Tcl_Interp *interp; /* Interpreter */
2447
int objc; /* How many arguments? */
2448
Tcl_Obj *CONST objv[]; /* The argument objects */
2450
static char *bdbverify[] = {
2462
TCL_DBVRFY_ENCRYPT_AES,
2463
TCL_DBVRFY_ENCRYPT_ANY,
2472
u_int32_t enc_flag, flags, set_flags;
2473
int endarg, i, optindex, result, ret;
2474
char *arg, *db, *errpfx, *passwd;
2483
enc_flag = set_flags = 0;
2486
Tcl_WrongNumArgs(interp, 2, objv, "?args? filename");
2491
* We must first parse for the environment flag, since that
2492
* is needed for db_create. Then create the db handle.
2496
if (Tcl_GetIndexFromObj(interp, objv[i], bdbverify,
2497
"option", TCL_EXACT, &optindex) != TCL_OK) {
2498
arg = Tcl_GetStringFromObj(objv[i], NULL);
2499
if (arg[0] == '-') {
2500
result = IS_HELP(objv[i]);
2503
Tcl_ResetResult(interp);
2507
switch ((enum bdbvrfy)optindex) {
2508
case TCL_DBVRFY_ENCRYPT:
2509
set_flags |= DB_ENCRYPT;
2512
case TCL_DBVRFY_ENCRYPT_AES:
2513
/* Make sure we have an arg to check against! */
2515
Tcl_WrongNumArgs(interp, 2, objv,
2516
"?-encryptaes passwd?");
2520
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
2521
enc_flag = DB_ENCRYPT_AES;
2523
case TCL_DBVRFY_ENCRYPT_ANY:
2524
/* Make sure we have an arg to check against! */
2526
Tcl_WrongNumArgs(interp, 2, objv,
2527
"?-encryptany passwd?");
2531
passwd = Tcl_GetStringFromObj(objv[i++], NULL);
2534
case TCL_DBVRFY_ENV:
2535
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2536
envp = NAME_TO_ENV(arg);
2538
Tcl_SetResult(interp,
2539
"db verify: illegal environment",
2545
case TCL_DBVRFY_ERRFILE:
2547
Tcl_WrongNumArgs(interp, 2, objv,
2552
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2554
* If the user already set one, close it.
2558
errf = fopen(arg, "a");
2560
case TCL_DBVRFY_ERRPFX:
2562
Tcl_WrongNumArgs(interp, 2, objv,
2567
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2569
* If the user already set one, free it.
2572
__os_free(envp, errpfx);
2573
if ((ret = __os_strdup(NULL, arg, &errpfx)) != 0) {
2574
result = _ReturnSetup(interp, ret,
2575
DB_RETOK_STD(ret), "__os_strdup");
2579
case TCL_DBVRFY_ENDARG:
2584
* If, at any time, parsing the args we get an error,
2585
* bail out and return.
2587
if (result != TCL_OK)
2592
if (result != TCL_OK)
2595
* The remaining arg is the db filename.
2597
if (i == (objc - 1))
2598
db = Tcl_GetStringFromObj(objv[i++], NULL);
2600
Tcl_WrongNumArgs(interp, 2, objv, "?args? filename");
2604
ret = db_create(&dbp, envp, 0);
2606
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2611
if (passwd != NULL) {
2612
ret = dbp->set_encrypt(dbp, passwd, enc_flag);
2613
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2617
if (set_flags != 0) {
2618
ret = dbp->set_flags(dbp, set_flags);
2619
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2623
dbp->set_errfile(dbp, errf);
2625
dbp->set_errpfx(dbp, errpfx);
2627
ret = dbp->verify(dbp, db, NULL, NULL, flags);
2628
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db verify");
2633
__os_free(envp, errpfx);
2635
(void)dbp->close(dbp, 0);
2642
* Implements the version command.
2645
bdb_Version(interp, objc, objv)
2646
Tcl_Interp *interp; /* Interpreter */
2647
int objc; /* How many arguments? */
2648
Tcl_Obj *CONST objv[]; /* The argument objects */
2650
static char *bdbver[] = {
2656
int i, optindex, maj, min, patch, result, string, verobjc;
2658
Tcl_Obj *res, *verobjv[3];
2664
Tcl_WrongNumArgs(interp, 2, objv, "?args?");
2669
* We must first parse for the environment flag, since that
2670
* is needed for db_create. Then create the db handle.
2674
if (Tcl_GetIndexFromObj(interp, objv[i], bdbver,
2675
"option", TCL_EXACT, &optindex) != TCL_OK) {
2676
arg = Tcl_GetStringFromObj(objv[i], NULL);
2677
if (arg[0] == '-') {
2678
result = IS_HELP(objv[i]);
2681
Tcl_ResetResult(interp);
2685
switch ((enum bdbver)optindex) {
2691
* If, at any time, parsing the args we get an error,
2692
* bail out and return.
2694
if (result != TCL_OK)
2697
if (result != TCL_OK)
2700
v = db_version(&maj, &min, &patch);
2702
res = Tcl_NewStringObj(v, strlen(v));
2705
verobjv[0] = Tcl_NewIntObj(maj);
2706
verobjv[1] = Tcl_NewIntObj(min);
2707
verobjv[2] = Tcl_NewIntObj(patch);
2708
res = Tcl_NewListObj(verobjc, verobjv);
2710
Tcl_SetObjResult(interp, res);
2718
* Implements the handles command.
2721
bdb_Handles(interp, objc, objv)
2722
Tcl_Interp *interp; /* Interpreter */
2723
int objc; /* How many arguments? */
2724
Tcl_Obj *CONST objv[]; /* The argument objects */
2727
Tcl_Obj *res, *handle;
2730
* No args. Error if we have some
2733
Tcl_WrongNumArgs(interp, 2, objv, "");
2736
res = Tcl_NewListObj(0, NULL);
2738
for (p = LIST_FIRST(&__db_infohead); p != NULL;
2739
p = LIST_NEXT(p, entries)) {
2740
handle = Tcl_NewStringObj(p->i_name, strlen(p->i_name));
2741
if (Tcl_ListObjAppendElement(interp, res, handle) != TCL_OK)
2744
Tcl_SetObjResult(interp, res);
2752
* Implements the DB->upgrade command.
2755
bdb_DbUpgrade(interp, objc, objv)
2756
Tcl_Interp *interp; /* Interpreter */
2757
int objc; /* How many arguments? */
2758
Tcl_Obj *CONST objv[]; /* The argument objects */
2760
static char *bdbupg[] = {
2761
"-dupsort", "-env", "--", NULL
2771
int endarg, i, optindex, result, ret;
2781
Tcl_WrongNumArgs(interp, 2, objv, "?args? filename");
2787
if (Tcl_GetIndexFromObj(interp, objv[i], bdbupg,
2788
"option", TCL_EXACT, &optindex) != TCL_OK) {
2789
arg = Tcl_GetStringFromObj(objv[i], NULL);
2790
if (arg[0] == '-') {
2791
result = IS_HELP(objv[i]);
2794
Tcl_ResetResult(interp);
2798
switch ((enum bdbupg)optindex) {
2799
case TCL_DBUPG_DUPSORT:
2800
flags |= DB_DUPSORT;
2803
arg = Tcl_GetStringFromObj(objv[i++], NULL);
2804
envp = NAME_TO_ENV(arg);
2806
Tcl_SetResult(interp,
2807
"db upgrade: illegal environment",
2812
case TCL_DBUPG_ENDARG:
2817
* If, at any time, parsing the args we get an error,
2818
* bail out and return.
2820
if (result != TCL_OK)
2825
if (result != TCL_OK)
2828
* The remaining arg is the db filename.
2830
if (i == (objc - 1))
2831
db = Tcl_GetStringFromObj(objv[i++], NULL);
2833
Tcl_WrongNumArgs(interp, 2, objv, "?args? filename");
2837
ret = db_create(&dbp, envp, 0);
2839
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
2844
ret = dbp->upgrade(dbp, db, flags);
2845
result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "db upgrade");
2848
(void)dbp->close(dbp, 0);
2854
* tcl_bt_compare and tcl_dup_compare --
2855
* These two are basically identical internally, so may as well
2856
* share code. The only differences are the name used in error
2857
* reporting and the Tcl_Obj representing their respective procs.
2860
tcl_bt_compare(dbp, dbta, dbtb)
2862
const DBT *dbta, *dbtb;
2864
return (tcl_compare_callback(dbp, dbta, dbtb,
2865
((DBTCL_INFO *)dbp->api_internal)->i_btcompare, "bt_compare"));
2869
tcl_dup_compare(dbp, dbta, dbtb)
2871
const DBT *dbta, *dbtb;
2873
return (tcl_compare_callback(dbp, dbta, dbtb,
2874
((DBTCL_INFO *)dbp->api_internal)->i_dupcompare, "dup_compare"));
2878
* tcl_compare_callback --
2879
* Tcl callback for set_bt_compare and set_dup_compare. What this
2880
* function does is stuff the data fields of the two DBTs into Tcl ByteArray
2881
* objects, then call the procedure stored in ip->i_btcompare on the two
2882
* objects. Then we return that procedure's result as the comparison.
2885
tcl_compare_callback(dbp, dbta, dbtb, procobj, errname)
2887
const DBT *dbta, *dbtb;
2893
Tcl_Obj *a, *b, *resobj, *objv[3];
2896
ip = (DBTCL_INFO *)dbp->api_internal;
2897
interp = ip->i_interp;
2901
* Create two ByteArray objects, with the two data we've been passed.
2902
* This will involve a copy, which is unpleasantly slow, but there's
2903
* little we can do to avoid this (I think).
2905
a = Tcl_NewByteArrayObj(dbta->data, dbta->size);
2906
Tcl_IncrRefCount(a);
2907
b = Tcl_NewByteArrayObj(dbtb->data, dbtb->size);
2908
Tcl_IncrRefCount(b);
2913
result = Tcl_EvalObjv(interp, 3, objv, 0);
2914
if (result != TCL_OK) {
2917
* If this or the next Tcl call fails, we're doomed.
2918
* There's no way to return an error from comparison functions,
2919
* no way to determine what the correct sort order is, and
2920
* so no way to avoid corrupting the database if we proceed.
2921
* We could play some games stashing return values on the
2922
* DB handle, but it's not worth the trouble--no one with
2923
* any sense is going to be using this other than for testing,
2924
* and failure typically means that the bt_compare proc
2925
* had a syntax error in it or something similarly dumb.
2927
* So, drop core. If we're not running with diagnostic
2928
* mode, panic--and always return a negative number. :-)
2930
panic: __db_err(dbp->dbenv, "Tcl %s callback failed", errname);
2932
return (__db_panic(dbp->dbenv, DB_RUNRECOVERY));
2935
resobj = Tcl_GetObjResult(interp);
2936
result = Tcl_GetIntFromObj(interp, resobj, &cmp);
2937
if (result != TCL_OK)
2940
Tcl_DecrRefCount(a);
2941
Tcl_DecrRefCount(b);
2947
* Tcl callback for the hashing function. See tcl_compare_callback--
2948
* this works much the same way, only we're given a buffer and a length
2949
* instead of two DBTs.
2952
tcl_h_hash(dbp, buf, len)
2962
ip = (DBTCL_INFO *)dbp->api_internal;
2963
interp = ip->i_interp;
2964
objv[0] = ip->i_hashproc;
2967
* Create a ByteArray for the buffer.
2969
objv[1] = Tcl_NewByteArrayObj((void *)buf, len);
2970
Tcl_IncrRefCount(objv[1]);
2971
result = Tcl_EvalObjv(interp, 2, objv, 0);
2972
if (result != TCL_OK) {
2975
* We drop core on error. See the comment in
2976
* tcl_compare_callback.
2978
panic: __db_err(dbp->dbenv, "Tcl h_hash callback failed");
2980
return (__db_panic(dbp->dbenv, DB_RUNRECOVERY));
2983
result = Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &hval);
2984
if (result != TCL_OK)
2987
Tcl_DecrRefCount(objv[1]);
2993
* Replication send callback.
2996
tcl_rep_send(dbenv, control, rec, eid, flags)
2998
const DBT *control, *rec;
3004
Tcl_Obj *control_o, *eid_o, *origobj, *rec_o, *resobj, *objv[5];
3007
COMPQUIET(flags, 0);
3009
ip = (DBTCL_INFO *)dbenv->app_private;
3010
interp = ip->i_interp;
3011
objv[0] = ip->i_rep_send;
3013
control_o = Tcl_NewByteArrayObj(control->data, control->size);
3014
Tcl_IncrRefCount(control_o);
3016
rec_o = Tcl_NewByteArrayObj(rec->data, rec->size);
3017
Tcl_IncrRefCount(rec_o);
3019
eid_o = Tcl_NewIntObj(eid);
3020
Tcl_IncrRefCount(eid_o);
3022
objv[1] = control_o;
3024
objv[3] = ip->i_rep_eid; /* From ID */
3025
objv[4] = eid_o; /* To ID */
3028
* We really want to return the original result to the
3029
* user. So, save the result obj here, and then after
3030
* we've taken care of the Tcl_EvalObjv, set the result
3031
* back to this original result.
3033
origobj = Tcl_GetObjResult(interp);
3034
Tcl_IncrRefCount(origobj);
3035
result = Tcl_EvalObjv(interp, 5, objv, 0);
3036
if (result != TCL_OK) {
3039
* This probably isn't the right error behavior, but
3040
* this error should only happen if the Tcl callback is
3041
* somehow invalid, which is a fatal scripting bug.
3043
err: __db_err(dbenv, "Tcl rep_send failure");
3047
resobj = Tcl_GetObjResult(interp);
3048
result = Tcl_GetIntFromObj(interp, resobj, &ret);
3049
if (result != TCL_OK)
3052
Tcl_SetObjResult(interp, origobj);
3053
Tcl_DecrRefCount(origobj);
3054
Tcl_DecrRefCount(control_o);
3055
Tcl_DecrRefCount(rec_o);
3056
Tcl_DecrRefCount(eid_o);
3063
* tcl_db_malloc, tcl_db_realloc, tcl_db_free --
3064
* Tcl-local malloc, realloc, and free functions to use for user data
3065
* to exercise umalloc/urealloc/ufree. Allocate the memory as a Tcl object
3066
* so we're sure to exacerbate and catch any shared-library issues.
3078
Tcl_IncrRefCount(obj);
3080
Tcl_SetObjLength(obj, size + sizeof(Tcl_Obj *));
3081
buf = Tcl_GetString(obj);
3082
memcpy(buf, &obj, sizeof(&obj));
3084
buf = (Tcl_Obj **)buf + 1;
3089
tcl_db_realloc(ptr, size)
3096
return (tcl_db_malloc(size));
3098
obj = *(Tcl_Obj **)((Tcl_Obj **)ptr - 1);
3099
Tcl_SetObjLength(obj, size + sizeof(Tcl_Obj *));
3101
ptr = Tcl_GetString(obj);
3102
memcpy(ptr, &obj, sizeof(&obj));
3104
ptr = (Tcl_Obj **)ptr + 1;
3114
obj = *(Tcl_Obj **)((Tcl_Obj **)ptr - 1);
3115
Tcl_DecrRefCount(obj);
added
removed
libdb/tcl/tcl_db_pkg.c
