开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 数据库系统 > MySQL数据库 > 查看源码
tcl_db.c
资源名称：mysql-3.23.35.tar.gz　[点击查看]
上传用户：tsgydb
上传日期：2007-04-14
资源大小：10674k
文件大小：42k
源码类别：

MySQL数据库

开发平台：

Visual C++

tcl_db.c：源码内容
  1. /*-
  2.  * See the file LICENSE for redistribution information.
  3.  *
  4.  * Copyright (c) 1999, 2000
  5.  * Sleepycat Software.  All rights reserved.
  6.  */
  8. #include "db_config.h"
  10. #ifndef lint
  11. static const char revid[] = "$Id: tcl_db.c,v 11.55 2000/11/28 20:12:31 bostic Exp $";
  12. #endif /* not lint */
  14. #ifndef NO_SYSTEM_INCLUDES
  15. #include <sys/types.h>
  17. #include <stdlib.h>
  18. #include <string.h>
  19. #include <tcl.h>
  20. #endif
  22. #include "db_int.h"
  23. #include "tcl_db.h"
  25. /*
  26.  * Prototypes for procedures defined later in this file:
  27.  */
  28. static int tcl_DbClose __P((Tcl_Interp *,
  29.     int, Tcl_Obj * CONST*, DB *, DBTCL_INFO *));
  30. static int tcl_DbDelete __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  31. static int tcl_DbGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  32. static int tcl_DbKeyRange __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  33. static int tcl_DbPut __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  34. static int tcl_DbStat __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  35. static int tcl_DbCursor __P((Tcl_Interp *,
  36.     int, Tcl_Obj * CONST*, DB *, DBC **));
  37. static int tcl_DbJoin __P((Tcl_Interp *,
  38.     int, Tcl_Obj * CONST*, DB *, DBC **));
  39. static int tcl_DbGetjoin __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  40. static int tcl_DbCount __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB *));
  42. /*
  43.  *
  44.  * PUBLIC: int db_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
  45.  *
  46.  * db_Cmd --
  47.  * Implements the "db" widget.
  48.  */
  49. int
  50. db_Cmd(clientData, interp, objc, objv)
  51. ClientData clientData; /* DB handle */
  52. Tcl_Interp *interp; /* Interpreter */
  53. int objc; /* How many arguments? */
  54. Tcl_Obj *CONST objv[]; /* The argument objects */
  55. {
  56. static char *dbcmds[] = {
  57. "close",
  58. "count",
  59. "cursor",
  60. "del",
  61. "get",
  62. "get_join",
  63. "get_type",
  64. "is_byteswapped",
  65. "join",
  66. "keyrange",
  67. "put",
  68. "stat",
  69. "sync",
  70. #if CONFIG_TEST
  71. "test",
  72. #endif
  73. NULL
  74. };
  75. enum dbcmds {
  76. DBCLOSE,
  77. DBCOUNT,
  78. DBCURSOR,
  79. DBDELETE,
  80. DBGET,
  81. DBGETJOIN,
  82. DBGETTYPE,
  83. DBSWAPPED,
  84. DBJOIN,
  85. DBKEYRANGE,
  86. DBPUT,
  87. DBSTAT,
  88. DBSYNC
  89. #if CONFIG_TEST
  90. , DBTEST
  91. #endif
  92. };
  93. DB *dbp;
  94. DBC *dbc;
  95. DBTCL_INFO *dbip;
  96. DBTCL_INFO *ip;
  97. Tcl_Obj *res;
  98. int cmdindex, result, ret;
  99. char newname[MSG_SIZE];
  101. Tcl_ResetResult(interp);
  102. dbp = (DB *)clientData;
  103. dbip = _PtrToInfo((void *)dbp);
  104. memset(newname, 0, MSG_SIZE);
  105. result = TCL_OK;
  106. if (objc <= 1) {
  107. Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
  108. return (TCL_ERROR);
  109. }
  110. if (dbp == NULL) {
  111. Tcl_SetResult(interp, "NULL db pointer", TCL_STATIC);
  112. return (TCL_ERROR);
  113. }
  114. if (dbip == NULL) {
  115. Tcl_SetResult(interp, "NULL db info pointer", TCL_STATIC);
  116. return (TCL_ERROR);
  117. }
  119. /*
  120.  * Get the command name index from the object based on the dbcmds
  121.  * defined above.
  122.  */
  123. if (Tcl_GetIndexFromObj(interp,
  124.     objv[1], dbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
  125. return (IS_HELP(objv[1]));
  127. res = NULL;
  128. switch ((enum dbcmds)cmdindex) {
  129. case DBCLOSE:
  130. result = tcl_DbClose(interp, objc, objv, dbp, dbip);
  131. break;
  132. case DBDELETE:
  133. result = tcl_DbDelete(interp, objc, objv, dbp);
  134. break;
  135. case DBGET:
  136. result = tcl_DbGet(interp, objc, objv, dbp);
  137. break;
  138. case DBKEYRANGE:
  139. result = tcl_DbKeyRange(interp, objc, objv, dbp);
  140. break;
  141. case DBPUT:
  142. result = tcl_DbPut(interp, objc, objv, dbp);
  143. break;
  144. case DBCOUNT:
  145. result = tcl_DbCount(interp, objc, objv, dbp);
  146. break;
  147. case DBSWAPPED:
  148. /*
  149.  * No args for this.  Error if there are some.
  150.  */
  151. if (objc > 2) {
  152. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  153. return (TCL_ERROR);
  154. }
  155. _debug_check();
  156. ret = dbp->get_byteswapped(dbp);
  157. res = Tcl_NewIntObj(ret);
  158. break;
  159. case DBGETTYPE:
  160. /*
  161.  * No args for this.  Error if there are some.
  162.  */
  163. if (objc > 2) {
  164. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  165. return (TCL_ERROR);
  166. }
  167. _debug_check();
  168. ret = dbp->get_type(dbp);
  169. if (ret == DB_BTREE)
  170. res = Tcl_NewStringObj("btree", strlen("btree"));
  171. else if (ret == DB_HASH)
  172. res = Tcl_NewStringObj("hash", strlen("hash"));
  173. else if (ret == DB_RECNO)
  174. res = Tcl_NewStringObj("recno", strlen("recno"));
  175. else if (ret == DB_QUEUE)
  176. res = Tcl_NewStringObj("queue", strlen("queue"));
  177. else {
  178. Tcl_SetResult(interp,
  179.     "db gettype: Returned unknown typen", TCL_STATIC);
  180. result = TCL_ERROR;
  181. }
  182. break;
  183. case DBSTAT:
  184. result = tcl_DbStat(interp, objc, objv, dbp);
  185. break;
  186. case DBSYNC:
  187. /*
  188.  * No args for this.  Error if there are some.
  189.  */
  190. if (objc > 2) {
  191. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  192. return (TCL_ERROR);
  193. }
  194. _debug_check();
  195. ret = dbp->sync(dbp, 0);
  196. res = Tcl_NewIntObj(ret);
  197. if (ret != 0) {
  198. Tcl_SetObjResult(interp, res);
  199. result = TCL_ERROR;
  200. }
  201. break;
  202. case DBCURSOR:
  203. snprintf(newname, sizeof(newname),
  204.     "%s.c%d", dbip->i_name, dbip->i_dbdbcid);
  205. ip = _NewInfo(interp, NULL, newname, I_DBC);
  206. if (ip != NULL) {
  207. result = tcl_DbCursor(interp, objc, objv, dbp, &dbc);
  208. if (result == TCL_OK) {
  209. dbip->i_dbdbcid++;
  210. ip->i_parent = dbip;
  211. Tcl_CreateObjCommand(interp, newname,
  212.     (Tcl_ObjCmdProc *)dbc_Cmd,
  213.     (ClientData)dbc, NULL);
  214. res =
  215.     Tcl_NewStringObj(newname, strlen(newname));
  216. _SetInfoData(ip, dbc);
  217. } else
  218. _DeleteInfo(ip);
  219. } else {
  220. Tcl_SetResult(interp,
  221.     "Could not set up info", TCL_STATIC);
  222. result = TCL_ERROR;
  223. }
  224. break;
  225. case DBJOIN:
  226. snprintf(newname, sizeof(newname),
  227.     "%s.c%d", dbip->i_name, dbip->i_dbdbcid);
  228. ip = _NewInfo(interp, NULL, newname, I_DBC);
  229. if (ip != NULL) {
  230. result = tcl_DbJoin(interp, objc, objv, dbp, &dbc);
  231. if (result == TCL_OK) {
  232. dbip->i_dbdbcid++;
  233. ip->i_parent = dbip;
  234. Tcl_CreateObjCommand(interp, newname,
  235.     (Tcl_ObjCmdProc *)dbc_Cmd,
  236.     (ClientData)dbc, NULL);
  237. res =
  238.     Tcl_NewStringObj(newname, strlen(newname));
  239. _SetInfoData(ip, dbc);
  240. } else
  241. _DeleteInfo(ip);
  242. } else {
  243. Tcl_SetResult(interp,
  244.     "Could not set up info", TCL_STATIC);
  245. result = TCL_ERROR;
  246. }
  247. break;
  248. case DBGETJOIN:
  249. result = tcl_DbGetjoin(interp, objc, objv, dbp);
  250. break;
  251. #if CONFIG_TEST
  252. case DBTEST:
  253. result = tcl_EnvTest(interp, objc, objv, dbp->dbenv);
  254. break;
  255. #endif
  256. }
  257. /*
  258.  * Only set result if we have a res.  Otherwise, lower
  259.  * functions have already done so.
  260.  */
  261. if (result == TCL_OK && res)
  262. Tcl_SetObjResult(interp, res);
  263. return (result);
  264. }
  266. /*
  267.  * tcl_db_stat --
  268.  */
  269. static int
  270. tcl_DbStat(interp, objc, objv, dbp)
  271. Tcl_Interp *interp; /* Interpreter */
  272. int objc; /* How many arguments? */
  273. Tcl_Obj *CONST objv[]; /* The argument objects */
  274. DB *dbp; /* Database pointer */
  275. {
  276. DB_BTREE_STAT *bsp;
  277. DB_HASH_STAT *hsp;
  278. DB_QUEUE_STAT *qsp;
  279. void *sp;
  280. Tcl_Obj *res;
  281. DBTYPE type;
  282. u_int32_t flag;
  283. int result, ret;
  284. char *arg;
  286. result = TCL_OK;
  287. flag = 0;
  289. if (objc > 3) {
  290. Tcl_WrongNumArgs(interp, 2, objv, "?-recordcount?");
  291. return (TCL_ERROR);
  292. }
  294. if (objc == 3) {
  295. arg = Tcl_GetStringFromObj(objv[2], NULL);
  296. if (strcmp(arg, "-recordcount") == 0)
  297. flag = DB_RECORDCOUNT;
  298. else if (strcmp(arg, "-cachedcounts") == 0)
  299. flag = DB_CACHED_COUNTS;
  300. else {
  301. Tcl_SetResult(interp,
  302.     "db stat: unknown arg", TCL_STATIC);
  303. return (TCL_ERROR);
  304. }
  305. }
  307. _debug_check();
  308. ret = dbp->stat(dbp, &sp, NULL, flag);
  309. result = _ReturnSetup(interp, ret, "db stat");
  310. if (result == TCL_ERROR)
  311. return (result);
  313. type = dbp->get_type(dbp);
  314. /*
  315.  * Have our stats, now construct the name value
  316.  * list pairs and free up the memory.
  317.  */
  318. res = Tcl_NewObj();
  319. /*
  320.  * MAKE_STAT_LIST assumes 'res' and 'error' label.
  321.  */
  322. if (type == DB_HASH) {
  323. hsp = (DB_HASH_STAT *)sp;
  324. MAKE_STAT_LIST("Magic", hsp->hash_magic);
  325. MAKE_STAT_LIST("Version", hsp->hash_version);
  326. MAKE_STAT_LIST("Page size", hsp->hash_pagesize);
  327. MAKE_STAT_LIST("Number of keys", hsp->hash_nkeys);
  328. MAKE_STAT_LIST("Number of records", hsp->hash_ndata);
  329. MAKE_STAT_LIST("Estim. number of elements", hsp->hash_nelem);
  330. MAKE_STAT_LIST("Fill factor", hsp->hash_ffactor);
  331. MAKE_STAT_LIST("Buckets", hsp->hash_buckets);
  332. MAKE_STAT_LIST("Free pages", hsp->hash_free);
  333. MAKE_STAT_LIST("Bytes free", hsp->hash_bfree);
  334. MAKE_STAT_LIST("Number of big pages", hsp->hash_bigpages);
  335. MAKE_STAT_LIST("Big pages bytes free", hsp->hash_big_bfree);
  336. MAKE_STAT_LIST("Overflow pages", hsp->hash_overflows);
  337. MAKE_STAT_LIST("Overflow bytes free", hsp->hash_ovfl_free);
  338. MAKE_STAT_LIST("Duplicate pages", hsp->hash_dup);
  339. MAKE_STAT_LIST("Duplicate pages bytes free",
  340.     hsp->hash_dup_free);
  341. } else if (type == DB_QUEUE) {
  342. qsp = (DB_QUEUE_STAT *)sp;
  343. MAKE_STAT_LIST("Magic", qsp->qs_magic);
  344. MAKE_STAT_LIST("Version", qsp->qs_version);
  345. MAKE_STAT_LIST("Page size", qsp->qs_pagesize);
  346. MAKE_STAT_LIST("Number of records", qsp->qs_ndata);
  347. MAKE_STAT_LIST("Number of pages", qsp->qs_pages);
  348. MAKE_STAT_LIST("Bytes free", qsp->qs_pgfree);
  349. MAKE_STAT_LIST("Record length", qsp->qs_re_len);
  350. MAKE_STAT_LIST("Record pad", qsp->qs_re_pad);
  351. MAKE_STAT_LIST("First record number", qsp->qs_first_recno);
  352. MAKE_STAT_LIST("Last record number", qsp->qs_cur_recno);
  353. } else { /* BTREE and RECNO are same stats */
  354. bsp = (DB_BTREE_STAT *)sp;
  355. MAKE_STAT_LIST("Number of keys", bsp->bt_nkeys);
  356. MAKE_STAT_LIST("Number of records", bsp->bt_ndata);
  357. if (flag != DB_RECORDCOUNT) {
  358. MAKE_STAT_LIST("Magic", bsp->bt_magic);
  359. MAKE_STAT_LIST("Version", bsp->bt_version);
  360. MAKE_STAT_LIST("Flags", bsp->bt_metaflags);
  361. MAKE_STAT_LIST("Minimum keys per page", bsp->bt_minkey);
  362. MAKE_STAT_LIST("Fixed record length", bsp->bt_re_len);
  363. MAKE_STAT_LIST("Record pad", bsp->bt_re_pad);
  364. MAKE_STAT_LIST("Page size", bsp->bt_pagesize);
  365. MAKE_STAT_LIST("Levels", bsp->bt_levels);
  366. MAKE_STAT_LIST("Internal pages", bsp->bt_int_pg);
  367. MAKE_STAT_LIST("Leaf pages", bsp->bt_leaf_pg);
  368. MAKE_STAT_LIST("Duplicate pages", bsp->bt_dup_pg);
  369. MAKE_STAT_LIST("Overflow pages", bsp->bt_over_pg);
  370. MAKE_STAT_LIST("Pages on freelist", bsp->bt_free);
  371. MAKE_STAT_LIST("Internal pages bytes free",
  372.     bsp->bt_int_pgfree);
  373. MAKE_STAT_LIST("Leaf pages bytes free",
  374.     bsp->bt_leaf_pgfree);
  375. MAKE_STAT_LIST("Duplicate pages bytes free",
  376.     bsp->bt_dup_pgfree);
  377. MAKE_STAT_LIST("Bytes free in overflow pages",
  378.     bsp->bt_over_pgfree);
  379. }
  380. }
  381. Tcl_SetObjResult(interp, res);
  382. error:
  383. __os_free(sp, 0);
  384. return (result);
  385. }
  387. /*
  388.  * tcl_db_close --
  389.  */
  390. static int
  391. tcl_DbClose(interp, objc, objv, dbp, dbip)
  392. Tcl_Interp *interp; /* Interpreter */
  393. int objc; /* How many arguments? */
  394. Tcl_Obj *CONST objv[]; /* The argument objects */
  395. DB *dbp; /* Database pointer */
  396. DBTCL_INFO *dbip; /* Info pointer */
  397. {
  398. DBTCL_INFO *p, *nextp;
  399. u_int32_t flag;
  400. int result, ret;
  401. char *arg;
  403. result = TCL_OK;
  404. flag = 0;
  405. if (objc > 3) {
  406. Tcl_WrongNumArgs(interp, 2, objv, "?-nosync?");
  407. return (TCL_ERROR);
  408. }
  410. if (objc == 3) {
  411. arg = Tcl_GetStringFromObj(objv[2], NULL);
  412. if (strcmp(arg, "-nosync") == 0)
  413. flag = DB_NOSYNC;
  414. else {
  415. Tcl_SetResult(interp,
  416.     "dbclose: unknown arg", TCL_STATIC);
  417. return (TCL_ERROR);
  418. }
  419. }
  421. /*
  422.  * First we have to close any open cursors.  Then we close
  423.  * our db.
  424.  */
  425. for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
  426. nextp = LIST_NEXT(p, entries);
  427. /*
  428.  * Check if this is a cursor info structure and if
  429.  * it is, if it belongs to this DB.  If so, remove
  430.  * its commands and info structure.
  431.  */
  432. if (p->i_parent == dbip && p->i_type == I_DBC) {
  433. (void)Tcl_DeleteCommand(interp, p->i_name);
  434. _DeleteInfo(p);
  435. }
  436. }
  437. (void)Tcl_DeleteCommand(interp, dbip->i_name);
  438. _DeleteInfo(dbip);
  439. _debug_check();
  440. ret = (dbp)->close(dbp, flag);
  441. result = _ReturnSetup(interp, ret, "db close");
  442. return (result);
  443. }
  445. /*
  446.  * tcl_db_put --
  447.  */
  448. static int
  449. tcl_DbPut(interp, objc, objv, dbp)
  450. Tcl_Interp *interp; /* Interpreter */
  451. int objc; /* How many arguments? */
  452. Tcl_Obj *CONST objv[]; /* The argument objects */
  453. DB *dbp; /* Database pointer */
  454. {
  455. static char *dbputopts[] = {
  456. "-append",
  457. "-nodupdata",
  458. "-nooverwrite",
  459. "-partial",
  460. "-txn",
  461. NULL
  462. };
  463. enum dbputopts {
  464. DBPUT_APPEND,
  465. DBGET_NODUPDATA,
  466. DBPUT_NOOVER,
  467. DBPUT_PART,
  468. DBPUT_TXN
  469. };
  470. static char *dbputapp[] = {
  471. "-append", NULL
  472. };
  473. enum dbputapp { DBPUT_APPEND0 };
  474. DBT key, data;
  475. DBTYPE type;
  476. DB_TXN *txn;
  477. Tcl_Obj **elemv, *res;
  478. db_recno_t recno;
  479. u_int32_t flag;
  480. int elemc, end, i, itmp, optindex, result, ret;
  481. char *arg, msg[MSG_SIZE];
  483. txn = NULL;
  484. result = TCL_OK;
  485. flag = 0;
  486. if (objc <= 3) {
  487. Tcl_WrongNumArgs(interp, 2, objv, "?-args? key data");
  488. return (TCL_ERROR);
  489. }
  491. memset(&key, 0, sizeof(key));
  492. memset(&data, 0, sizeof(data));
  494. /*
  495.  * If it is a QUEUE or RECNO database, the key is a record number
  496.  * and must be setup up to contain a db_recno_t.  Otherwise the
  497.  * key is a "string".
  498.  */
  499. type = dbp->get_type(dbp);
  501. /*
  502.  * We need to determine where the end of required args are.  If we
  503.  * are using a QUEUE/RECNO db and -append, then there is just one
  504.  * req arg (data).  Otherwise there are two (key data).
  505.  *
  506.  * We preparse the list to determine this since we need to know
  507.  * to properly check # of args for other options below.
  508.  */
  509. end = objc - 2;
  510. if (type == DB_QUEUE || type == DB_RECNO) {
  511. i = 2;
  512. while (i < objc - 1) {
  513. if (Tcl_GetIndexFromObj(interp, objv[i++], dbputapp,
  514.     "option", TCL_EXACT, &optindex) != TCL_OK)
  515. continue;
  516. switch ((enum dbputapp)optindex) {
  517. case DBPUT_APPEND0:
  518. end = objc - 1;
  519. break;
  520. }
  521. }
  522. }
  523. Tcl_ResetResult(interp);
  525. /*
  526.  * Get the command name index from the object based on the options
  527.  * defined above.
  528.  */
  529. i = 2;
  530. while (i < end) {
  531. if (Tcl_GetIndexFromObj(interp, objv[i],
  532.     dbputopts, "option", TCL_EXACT, &optindex) != TCL_OK)
  533. return (IS_HELP(objv[i]));
  534. i++;
  535. switch ((enum dbputopts)optindex) {
  536. case DBPUT_TXN:
  537. if (i > (end - 1)) {
  538. Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
  539. result = TCL_ERROR;
  540. break;
  541. }
  542. arg = Tcl_GetStringFromObj(objv[i++], NULL);
  543. txn = NAME_TO_TXN(arg);
  544. if (txn == NULL) {
  545. snprintf(msg, MSG_SIZE,
  546.     "Put: Invalid txn: %sn", arg);
  547. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  548. result = TCL_ERROR;
  549. }
  550. break;
  551. case DBPUT_APPEND:
  552. FLAG_CHECK(flag);
  553. flag = DB_APPEND;
  554. break;
  555. case DBGET_NODUPDATA:
  556. FLAG_CHECK(flag);
  557. flag = DB_NODUPDATA;
  558. break;
  559. case DBPUT_NOOVER:
  560. FLAG_CHECK(flag);
  561. flag = DB_NOOVERWRITE;
  562. break;
  563. case DBPUT_PART:
  564. if (i > (end - 1)) {
  565. Tcl_WrongNumArgs(interp, 2, objv,
  566.     "?-partial {offset length}?");
  567. result = TCL_ERROR;
  568. break;
  569. }
  570. /*
  571.  * Get sublist as {offset length}
  572.  */
  573. result = Tcl_ListObjGetElements(interp, objv[i++],
  574.     &elemc, &elemv);
  575. if (elemc != 2) {
  576. Tcl_SetResult(interp,
  577.     "List must be {offset length}", TCL_STATIC);
  578. result = TCL_ERROR;
  579. break;
  580. }
  581. data.flags = DB_DBT_PARTIAL;
  582. result = Tcl_GetIntFromObj(interp, elemv[0], &itmp);
  583. data.doff = itmp;
  584. if (result != TCL_OK)
  585. break;
  586. result = Tcl_GetIntFromObj(interp, elemv[1], &itmp);
  587. data.dlen = itmp;
  588. /*
  589.  * NOTE: We don't check result here because all we'd
  590.  * do is break anyway, and we are doing that.  If you
  591.  * add code here, you WILL need to add the check
  592.  * for result.  (See the check for save.doff, a few
  593.  * lines above and copy that.)
  594.  */
  595. break;
  596. }
  597. if (result != TCL_OK)
  598. break;
  599. }
  601. if (result == TCL_ERROR)
  602. return (result);
  604. /*
  605.  * If we are a recno db and we are NOT using append, then the 2nd
  606.  * last arg is the key.
  607.  */
  608. if (type == DB_QUEUE || type == DB_RECNO) {
  609. key.data = &recno;
  610. key.ulen = key.size = sizeof(db_recno_t);
  611. key.flags = DB_DBT_USERMEM;
  612. if (flag == DB_APPEND)
  613. recno = 0;
  614. else {
  615. result = Tcl_GetIntFromObj(interp, objv[objc-2], &itmp);
  616. recno = itmp;
  617. if (result != TCL_OK)
  618. return (result);
  619. }
  620. } else {
  621. key.data = Tcl_GetByteArrayFromObj(objv[objc-2], &itmp);
  622. key.size = itmp;
  623. }
  624. /*
  625.  * XXX
  626.  * Tcl 8.1 Tcl_GetByteArrayFromObj/Tcl_GetIntFromObj bug.
  627.  *
  628.  * This line (and the line for key.data above) were moved from
  629.  * the beginning of the function to here.
  630.  *
  631.  * There is a bug in Tcl 8.1 and byte arrays in that if it happens
  632.  * to use an object as both a byte array and something else like
  633.  * an int, and you've done a Tcl_GetByteArrayFromObj, then you
  634.  * do a Tcl_GetIntFromObj, your memory is deleted.
  635.  *
  636.  * Workaround is to make sure all Tcl_GetByteArrayFromObj calls
  637.  * are done last.
  638.  */
  639. data.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp);
  640. data.size = itmp;
  641. _debug_check();
  642. ret = dbp->put(dbp, txn, &key, &data, flag);
  643. result = _ReturnSetup(interp, ret, "db put");
  644. if (ret == 0 &&
  645.     (type == DB_RECNO || type == DB_QUEUE) && flag == DB_APPEND) {
  646. res = Tcl_NewIntObj(recno);
  647. Tcl_SetObjResult(interp, res);
  648. }
  649. return (result);
  650. }
  652. /*
  653.  * tcl_db_get --
  654.  */
  655. static int
  656. tcl_DbGet(interp, objc, objv, dbp)
  657. Tcl_Interp *interp; /* Interpreter */
  658. int objc; /* How many arguments? */
  659. Tcl_Obj *CONST objv[]; /* The argument objects */
  660. DB *dbp; /* Database pointer */
  661. {
  662. static char *dbgetopts[] = {
  663. "-consume",
  664. "-consume_wait",
  665. "-get_both",
  666. "-glob",
  667. "-partial",
  668. "-recno",
  669. "-rmw",
  670. "-txn",
  671. NULL
  672. };
  673. enum dbgetopts {
  674. DBGET_CONSUME,
  675. DBGET_CONSUME_WAIT,
  676. DBGET_BOTH,
  677. DBGET_GLOB,
  678. DBGET_PART,
  679. DBGET_RECNO,
  680. DBGET_RMW,
  681. DBGET_TXN
  682. };
  683. DBC *dbc;
  684. DBT key, data, save;
  685. DBTYPE type;
  686. DB_TXN *txn;
  687. Tcl_Obj **elemv, *retlist;
  688. db_recno_t recno;
  689. u_int32_t flag, cflag, isdup, rmw;
  690. int elemc, end, i, itmp, optindex, result, ret, useglob, userecno;
  691. char *arg, *pattern, *prefix, msg[MSG_SIZE];
  693. result = TCL_OK;
  694. cflag = flag = rmw = 0;
  695. useglob = userecno = 0;
  696. txn = NULL;
  697. pattern = prefix = NULL;
  699. if (objc < 3) {
  700. Tcl_WrongNumArgs(interp, 2, objv, "?-args? key");
  701. return (TCL_ERROR);
  702. }
  704. memset(&key, 0, sizeof(key));
  705. memset(&data, 0, sizeof(data));
  706. memset(&save, 0, sizeof(save));
  708. /*
  709.  * Get the command name index from the object based on the options
  710.  * defined above.
  711.  */
  712. i = 2;
  713. type = dbp->get_type(dbp);
  714. end = objc;
  715. while (i < end) {
  716. if (Tcl_GetIndexFromObj(interp, objv[i], dbgetopts, "option",
  717.     TCL_EXACT, &optindex) != TCL_OK) {
  718. if (IS_HELP(objv[i]) == TCL_OK)
  719. return (TCL_OK);
  720. Tcl_ResetResult(interp);
  721. break;
  722. }
  723. i++;
  724. switch ((enum dbgetopts)optindex) {
  725. case DBGET_BOTH:
  726. /*
  727.  * Change 'end' and make sure we aren't already past
  728.  * the new end.
  729.  */
  730. if (i > objc - 2) {
  731. Tcl_WrongNumArgs(interp, 2, objv,
  732.     "?-get_both key data?");
  733. result = TCL_ERROR;
  734. break;
  735. }
  736. end = objc - 2;
  737. FLAG_CHECK(flag);
  738. flag = DB_GET_BOTH;
  739. break;
  740. case DBGET_TXN:
  741. if (i == end - 1) {
  742. Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
  743. result = TCL_ERROR;
  744. break;
  745. }
  746. arg = Tcl_GetStringFromObj(objv[i++], NULL);
  747. txn = NAME_TO_TXN(arg);
  748. if (txn == NULL) {
  749. snprintf(msg, MSG_SIZE,
  750.     "Get: Invalid txn: %sn", arg);
  751. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  752. result = TCL_ERROR;
  753. }
  754. break;
  755. case DBGET_GLOB:
  756. useglob = 1;
  757. end = objc - 1;
  758. break;
  759. case DBGET_CONSUME:
  760. FLAG_CHECK(flag);
  761. flag = DB_CONSUME;
  762. break;
  763. case DBGET_CONSUME_WAIT:
  764. FLAG_CHECK(flag);
  765. flag = DB_CONSUME_WAIT;
  766. break;
  767. case DBGET_RECNO:
  768. end = objc - 1;
  769. userecno = 1;
  770. if (type != DB_RECNO && type != DB_QUEUE) {
  771. FLAG_CHECK(flag);
  772. flag = DB_SET_RECNO;
  773. }
  774. break;
  775. case DBGET_RMW:
  776. rmw = DB_RMW;
  777. break;
  778. case DBGET_PART:
  779. end = objc - 1;
  780. if (i == end) {
  781. Tcl_WrongNumArgs(interp, 2, objv,
  782.     "?-partial {offset length}?");
  783. result = TCL_ERROR;
  784. break;
  785. }
  786. /*
  787.  * Get sublist as {offset length}
  788.  */
  789. result = Tcl_ListObjGetElements(interp, objv[i++],
  790.     &elemc, &elemv);
  791. if (elemc != 2) {
  792. Tcl_SetResult(interp,
  793.     "List must be {offset length}", TCL_STATIC);
  794. result = TCL_ERROR;
  795. break;
  796. }
  797. save.flags = DB_DBT_PARTIAL;
  798. result = Tcl_GetIntFromObj(interp, elemv[0], &itmp);
  799. save.doff = itmp;
  800. if (result != TCL_OK)
  801. break;
  802. result = Tcl_GetIntFromObj(interp, elemv[1], &itmp);
  803. save.dlen = itmp;
  804. /*
  805.  * NOTE: We don't check result here because all we'd
  806.  * do is break anyway, and we are doing that.  If you
  807.  * add code here, you WILL need to add the check
  808.  * for result.  (See the check for save.doff, a few
  809.  * lines above and copy that.)
  810.  */
  811. break;
  812. }
  813. if (result != TCL_OK)
  814. break;
  815. }
  816. if (result != TCL_OK)
  817. goto out;
  819. if (type == DB_RECNO || type == DB_QUEUE)
  820. userecno = 1;
  821. /*
  822.  * Check for illegal combos of options.
  823.  */
  824. if (useglob && (userecno || flag == DB_SET_RECNO ||
  825.     type == DB_RECNO || type == DB_QUEUE)) {
  826. Tcl_SetResult(interp,
  827.     "Cannot use -glob and record numbers.n",
  828.     TCL_STATIC);
  829. result = TCL_ERROR;
  830. goto out;
  831. }
  832. if (useglob && flag == DB_GET_BOTH) {
  833. Tcl_SetResult(interp,
  834.     "Only one of -glob or -get_both can be specified.n",
  835.     TCL_STATIC);
  836. result = TCL_ERROR;
  837. goto out;
  838. }
  840. if (useglob)
  841. pattern = Tcl_GetStringFromObj(objv[objc - 1], NULL);
  843. /*
  844.  * This is the list we return
  845.  */
  846. retlist = Tcl_NewListObj(0, NULL);
  847. save.flags |= DB_DBT_MALLOC;
  849. /*
  850.  * isdup is used to know if we support duplicates.  If not, we
  851.  * can just do a db->get call and avoid using cursors.
  852.  * XXX
  853.  * When there is a db->get_flags method, it should be used.
  854.  * isdup = dbp->get_flags(dbp) & DB_DUP;
  855.  * For now we illegally peek.
  856.  * XXX
  857.  */
  858. isdup = dbp->flags & DB_AM_DUP;
  860. /*
  861.  * If the database doesn't support duplicates or we're performing
  862.  * ops that don't require returning multiple items, use DB->get
  863.  * instead of a cursor operation.
  864.  */
  865. if (pattern == NULL && (isdup == 0 ||
  866.     flag == DB_SET_RECNO || flag == DB_GET_BOTH ||
  867.     flag == DB_CONSUME || flag == DB_CONSUME_WAIT)) {
  868. if (flag == DB_GET_BOTH) {
  869. if (userecno) {
  870. result = Tcl_GetIntFromObj(interp,
  871.     objv[(objc - 2)], &itmp);
  872. recno = itmp;
  873. if (result == TCL_OK) {
  874. key.data = &recno;
  875. key.size = sizeof(db_recno_t);
  876. } else
  877. return (result);
  878. } else {
  879. key.data =
  880.     Tcl_GetByteArrayFromObj(objv[objc-2],
  881.     &itmp);
  882. key.size = itmp;
  883. }
  884. /*
  885.  * Already checked args above.  Fill in key and save.
  886.  * Save is used in the dbp->get call below to fill in
  887.  * data.
  888.  */
  889. save.data =
  890.     Tcl_GetByteArrayFromObj(objv[objc-1], &itmp);
  891. save.size = itmp;
  892. } else if (flag != DB_CONSUME && flag != DB_CONSUME_WAIT) {
  893. if (userecno) {
  894. result = Tcl_GetIntFromObj(
  895.     interp, objv[(objc - 1)], &itmp);
  896. recno = itmp;
  897. if (result == TCL_OK) {
  898. key.data = &recno;
  899. key.size = sizeof(db_recno_t);
  900. } else
  901. return (result);
  902. } else {
  903. key.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp);
  904. key.size = itmp;
  905. }
  906. }
  908. memset(&data, 0, sizeof(data));
  909. data = save;
  911. _debug_check();
  913. ret = dbp->get(dbp, txn, &key, &data, flag | rmw);
  914. result = _ReturnSetup(interp, ret, "db get");
  915. if (ret == 0) {
  916. /*
  917.  * Success.  Return a list of the form {name value}
  918.  * If it was a recno in key.data, we need to convert
  919.  * into a string/object representation of that recno.
  920.  */
  921. if (type == DB_RECNO || type == DB_QUEUE)
  922. result = _SetListRecnoElem(interp, retlist,
  923.     *(db_recno_t *)key.data, data.data,
  924.     data.size);
  925. else
  926. result = _SetListElem(interp, retlist,
  927.     key.data, key.size, data.data, data.size);
  928. /*
  929.  * Free space from DB_DBT_MALLOC
  930.  */
  931. __os_free(data.data, data.size);
  932. }
  933. if (result == TCL_OK)
  934. Tcl_SetObjResult(interp, retlist);
  935. goto out;
  936. }
  938. if (userecno) {
  939. result = Tcl_GetIntFromObj(interp, objv[(objc - 1)], &itmp);
  940. recno = itmp;
  941. if (result == TCL_OK) {
  942. key.data = &recno;
  943. key.size = sizeof(db_recno_t);
  944. } else
  945. return (result);
  946. } else {
  947. key.data = Tcl_GetByteArrayFromObj(objv[objc-1], &itmp);
  948. key.size = itmp;
  949. }
  950. ret = dbp->cursor(dbp, txn, &dbc, 0);
  951. result = _ReturnSetup(interp, ret, "db cursor");
  952. if (result == TCL_ERROR)
  953. goto out;
  955. /*
  956.  * At this point, we have a cursor, if we have a pattern,
  957.  * we go to the nearest one and step forward until we don't
  958.  * have any more that match the pattern prefix.  If we have
  959.  * an exact key, we go to that key position, and step through
  960.  * all the duplicates.  In either case we build up a list of
  961.  * the form {{key data} {key data}...} along the way.
  962.  */
  963. memset(&data, 0, sizeof(data));
  964. /*
  965.  * Restore any "partial" info we have saved.
  966.  */
  967. data = save;
  968. if (pattern) {
  969. /*
  970.  * Note, prefix is returned in new space.  Must free it.
  971.  */
  972. ret = _GetGlobPrefix(pattern, &prefix);
  973. if (ret) {
  974. result = TCL_ERROR;
  975. Tcl_SetResult(interp,
  976.     "Unable to allocate pattern space", TCL_STATIC);
  977. goto out1;
  978. }
  979. key.data = prefix;
  980. key.size = strlen(prefix);
  981. /*
  982.  * If they give us an empty pattern string
  983.  * (i.e. -glob *), go through entire DB.
  984.  */
  985. if (strlen(prefix) == 0)
  986. cflag = DB_FIRST;
  987. else
  988. cflag = DB_SET_RANGE;
  989. } else
  990. cflag = DB_SET;
  991. _debug_check();
  992. ret = dbc->c_get(dbc, &key, &data, cflag | rmw);
  993. result = _ReturnSetup(interp, ret, "db get (cursor)");
  994. if (result == TCL_ERROR)
  995. goto out1;
  996. if (pattern)
  997. cflag = DB_NEXT;
  998.  else
  999. cflag = DB_NEXT_DUP;
  1001. while (ret == 0 && result == TCL_OK) {
  1002. /*
  1003.  * Build up our {name value} sublist
  1004.  */
  1005. result = _SetListElem(interp, retlist,
  1006. key.data, key.size,
  1007. data.data, data.size);
  1008. /*
  1009.  * Free space from DB_DBT_MALLOC
  1010.  */
  1011. __os_free(data.data, data.size);
  1012. if (result != TCL_OK)
  1013. break;
  1014. /*
  1015.  * Append {name value} to return list
  1016.  */
  1017. memset(&key, 0, sizeof(key));
  1018. memset(&data, 0, sizeof(data));
  1019. /*
  1020.  * Restore any "partial" info we have saved.
  1021.  */
  1022. data = save;
  1023. ret = dbc->c_get(dbc, &key, &data, cflag | rmw);
  1024. if (ret == 0 && pattern &&
  1025.     memcmp(key.data, prefix, strlen(prefix)) != 0) {
  1026. /*
  1027.  * Free space from DB_DBT_MALLOC
  1028.  */
  1029. __os_free(data.data, data.size);
  1030. break;
  1031. }
  1032. }
  1033. dbc->c_close(dbc);
  1034. out1:
  1035. if (result == TCL_OK)
  1036. Tcl_SetObjResult(interp, retlist);
  1037. out:
  1038. /*
  1039.  * _GetGlobPrefix(), the function which allocates prefix, works
  1040.  * by copying and condensing another string.  Thus prefix may
  1041.  * have multiple nuls at the end, so we free using __os_free().
  1042.  */
  1043. if (prefix != NULL)
  1044. __os_free(prefix,0);
  1045. return (result);
  1046. }
  1048. /*
  1049.  * tcl_db_delete --
  1050.  */
  1051. static int
  1052. tcl_DbDelete(interp, objc, objv, dbp)
  1053. Tcl_Interp *interp; /* Interpreter */
  1054. int objc; /* How many arguments? */
  1055. Tcl_Obj *CONST objv[]; /* The argument objects */
  1056. DB *dbp; /* Database pointer */
  1057. {
  1058. static char *dbdelopts[] = {
  1059. "-glob",
  1060. "-txn",
  1061. NULL
  1062. };
  1063. enum dbdelopts {
  1064. DBDEL_GLOB,
  1065. DBDEL_TXN
  1066. };
  1067. DBC *dbc;
  1068. DBT key, data;
  1069. DBTYPE type;
  1070. DB_TXN *txn;
  1071. db_recno_t recno;
  1072. int i, itmp, optindex, result, ret;
  1073. u_int32_t flag;
  1074. char *arg, *pattern, *prefix, msg[MSG_SIZE];
  1076. result = TCL_OK;
  1077. flag = 0;
  1078. pattern = prefix = NULL;
  1079. txn = NULL;
  1080. if (objc < 3) {
  1081. Tcl_WrongNumArgs(interp, 2, objv, "?-args? key");
  1082. return (TCL_ERROR);
  1083. }
  1085. memset(&key, 0, sizeof(key));
  1086. /*
  1087.  * The first arg must be -txn, -glob or a list of keys.
  1088.  */
  1089. i = 2;
  1090. while (i < objc) {
  1091. if (Tcl_GetIndexFromObj(interp, objv[i], dbdelopts, "option",
  1092.     TCL_EXACT, &optindex) != TCL_OK) {
  1093. /*
  1094.  * If we don't have a -glob or -txn, then the
  1095.  * remaining args must be exact keys.
  1096.  * Reset the result so we don't get
  1097.  * an errant error message if there is another error.
  1098.  */
  1099. if (IS_HELP(objv[i]) == TCL_OK)
  1100. return (TCL_OK);
  1101. Tcl_ResetResult(interp);
  1102. break;
  1103. }
  1104. i++;
  1105. switch ((enum dbdelopts)optindex) {
  1106. case DBDEL_TXN:
  1107. if (i == objc) {
  1108. /*
  1109.  * Someone could conceivably have a key of
  1110.  * the same name.  So just break and use it.
  1111.  */
  1112. i--;
  1113. break;
  1114. }
  1115. arg = Tcl_GetStringFromObj(objv[i++], NULL);
  1116. txn = NAME_TO_TXN(arg);
  1117. if (txn == NULL) {
  1118. snprintf(msg, MSG_SIZE,
  1119.     "Delete: Invalid txn: %sn", arg);
  1120. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  1121. result = TCL_ERROR;
  1122. }
  1123. break;
  1124. case DBDEL_GLOB:
  1125. /*
  1126.  * Get the pattern.  Get the prefix and use cursors to
  1127.  * get all the data items.
  1128.  */
  1129. if (i == objc) {
  1130. /*
  1131.  * Someone could conceivably have a key of
  1132.  * the same name.  So just break and use it.
  1133.  */
  1134. i--;
  1135. break;
  1136. }
  1137. pattern = Tcl_GetStringFromObj(objv[i++], NULL);
  1138. break;
  1139. }
  1140. if (result != TCL_OK)
  1141. break;
  1142. }
  1144. if (result != TCL_OK)
  1145. goto out;
  1147. /*
  1148.  * If we have a pattern AND more keys to process, then there
  1149.  * is an error.  Either we have some number of exact keys,
  1150.  * or we have a pattern.
  1151.  */
  1152. if (pattern != NULL && i != objc) {
  1153. Tcl_WrongNumArgs(interp, 2, objv, "?args? -glob pattern | key");
  1154. result = TCL_ERROR;
  1155. goto out;
  1156. }
  1157. /*
  1158.  * XXX
  1159.  * For consistency with get, we have decided for the moment, to
  1160.  * allow -glob, or one key, not many.  The code was originally
  1161.  * written to take many keys and we'll leave it that way, because
  1162.  * tcl_DbGet may one day accept many disjoint keys to get, rather
  1163.  * than one, and at that time we'd make delete be consistent.  In
  1164.  * any case, the code is already here and there is no need to remove,
  1165.  * just check that we only have one arg left.
  1166.  */
  1167. if (pattern == NULL && i != (objc - 1)) {
  1168. Tcl_WrongNumArgs(interp, 2, objv, "?args? -glob pattern | key");
  1169. result = TCL_ERROR;
  1170. goto out;
  1171. }
  1173. /*
  1174.  * If we have remaining args, they are all exact keys.  Call
  1175.  * DB->del on each of those keys.
  1176.  *
  1177.  * If it is a RECNO database, the key is a record number and must be
  1178.  * setup up to contain a db_recno_t.  Otherwise the key is a "string".
  1179.  */
  1180. type = dbp->get_type(dbp);
  1181. ret = 0;
  1182. while (i < objc && ret == 0) {
  1183. memset(&key, 0, sizeof(key));
  1184. if (type == DB_RECNO || type == DB_QUEUE) {
  1185. result = Tcl_GetIntFromObj(interp, objv[i++], &itmp);
  1186. recno = itmp;
  1187. if (result == TCL_OK) {
  1188. key.data = &recno;
  1189. key.size = sizeof(db_recno_t);
  1190. } else
  1191. return (result);
  1192. } else {
  1193. key.data = Tcl_GetByteArrayFromObj(objv[i++], &itmp);
  1194. key.size = itmp;
  1195. }
  1196. _debug_check();
  1197. ret = dbp->del(dbp, txn, &key, 0);
  1198. /*
  1199.  * If we have any error, set up return result and stop
  1200.  * processing keys.
  1201.  */
  1202. if (ret != 0)
  1203. break;
  1204. }
  1205. result = _ReturnSetup(interp, ret, "db del");
  1207. /*
  1208.  * At this point we've either finished or, if we have a pattern,
  1209.  * we go to the nearest one and step forward until we don't
  1210.  * have any more that match the pattern prefix.
  1211.  */
  1212. if (pattern) {
  1213. ret = dbp->cursor(dbp, txn, &dbc, 0);
  1214. if (ret != 0) {
  1215. result = _ReturnSetup(interp, ret, "db cursor");
  1216. goto out;
  1217. }
  1218. /*
  1219.  * Note, prefix is returned in new space.  Must free it.
  1220.  */
  1221. memset(&key, 0, sizeof(key));
  1222. memset(&data, 0, sizeof(data));
  1223. ret = _GetGlobPrefix(pattern, &prefix);
  1224. if (ret) {
  1225. result = TCL_ERROR;
  1226. Tcl_SetResult(interp,
  1227.     "Unable to allocate pattern space", TCL_STATIC);
  1228. goto out;
  1229. }
  1230. key.data = prefix;
  1231. key.size = strlen(prefix);
  1232. if (strlen(prefix) == 0)
  1233. flag = DB_FIRST;
  1234. else
  1235. flag = DB_SET_RANGE;
  1236. ret = dbc->c_get(dbc, &key, &data, flag);
  1237. while (ret == 0 &&
  1238.     memcmp(key.data, prefix, strlen(prefix)) == 0) {
  1239. /*
  1240.  * Each time through here the cursor is pointing
  1241.  * at the current valid item.  Delete it and
  1242.  * move ahead.
  1243.  */
  1244. _debug_check();
  1245. ret = dbc->c_del(dbc, 0);
  1246. if (ret != 0) {
  1247. result = _ReturnSetup(interp, ret, "db c_del");
  1248. break;
  1249. }
  1250. /*
  1251.  * Deleted the current, now move to the next item
  1252.  * in the list, check if it matches the prefix pattern.
  1253.  */
  1254. memset(&key, 0, sizeof(key));
  1255. memset(&data, 0, sizeof(data));
  1256. ret = dbc->c_get(dbc, &key, &data, DB_NEXT);
  1257. }
  1258. if (ret == DB_NOTFOUND)
  1259. ret = 0;
  1260. /*
  1261.  * _GetGlobPrefix(), the function which allocates prefix, works
  1262.  * by copying and condensing another string.  Thus prefix may
  1263.  * have multiple nuls at the end, so we free using __os_free().
  1264.  */
  1265. __os_free(prefix,0);
  1266. dbc->c_close(dbc);
  1267. result = _ReturnSetup(interp, ret, "db del");
  1268. }
  1269. out:
  1270. return (result);
  1271. }
  1273. /*
  1274.  * tcl_db_cursor --
  1275.  */
  1276. static int
  1277. tcl_DbCursor(interp, objc, objv, dbp, dbcp)
  1278. Tcl_Interp *interp; /* Interpreter */
  1279. int objc; /* How many arguments? */
  1280. Tcl_Obj *CONST objv[]; /* The argument objects */
  1281. DB *dbp; /* Database pointer */
  1282. DBC **dbcp; /* Return cursor pointer */
  1283. {
  1284. static char *dbcuropts[] = {
  1285. "-txn", "-update",
  1286. NULL
  1287. };
  1288. enum dbcuropts {
  1289. DBCUR_TXN, DBCUR_UPDATE
  1290. };
  1291. DB_TXN *txn;
  1292. u_int32_t flag;
  1293. int i, optindex, result, ret;
  1294. char *arg, msg[MSG_SIZE];
  1296. result = TCL_OK;
  1297. flag = 0;
  1298. txn = NULL;
  1299. /*
  1300.  * If the user asks for -glob or -recno, it MUST be the second
  1301.  * last arg given.  If it isn't given, then we must check if
  1302.  * they gave us a correct key.
  1303.  */
  1304. i = 2;
  1305. while (i < objc) {
  1306. if (Tcl_GetIndexFromObj(interp, objv[i], dbcuropts, "option",
  1307.     TCL_EXACT, &optindex) != TCL_OK) {
  1308. result = IS_HELP(objv[i]);
  1309. goto out;
  1310. }
  1311. i++;
  1312. switch ((enum dbcuropts)optindex) {
  1313. case DBCUR_TXN:
  1314. if (i == objc) {
  1315. Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
  1316. result = TCL_ERROR;
  1317. break;
  1318. }
  1319. arg = Tcl_GetStringFromObj(objv[i++], NULL);
  1320. txn = NAME_TO_TXN(arg);
  1321. if (txn == NULL) {
  1322. snprintf(msg, MSG_SIZE,
  1323.     "Cursor: Invalid txn: %sn", arg);
  1324. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  1325. result = TCL_ERROR;
  1326. }
  1327. break;
  1328. case DBCUR_UPDATE:
  1329. flag = DB_WRITECURSOR;
  1330. break;
  1331. }
  1332. if (result != TCL_OK)
  1333. break;
  1334. }
  1335. if (result != TCL_OK)
  1336. goto out;
  1338. _debug_check();
  1339. ret = dbp->cursor(dbp, txn, dbcp, flag);
  1340. if (ret != 0)
  1341. result = _ErrorSetup(interp, ret, "db cursor");
  1342. out:
  1343. return (result);
  1344. }
  1346. /*
  1347.  * tcl_db_join --
  1348.  */
  1349. static int
  1350. tcl_DbJoin(interp, objc, objv, dbp, dbcp)
  1351. Tcl_Interp *interp; /* Interpreter */
  1352. int objc; /* How many arguments? */
  1353. Tcl_Obj *CONST objv[]; /* The argument objects */
  1354. DB *dbp; /* Database pointer */
  1355. DBC **dbcp; /* Cursor pointer */
  1356. {
  1357. static char *dbjopts[] = {
  1358. "-nosort",
  1359. NULL
  1360. };
  1361. enum dbjopts {
  1362. DBJ_NOSORT
  1363. };
  1364. DBC **listp;
  1365. u_int32_t flag;
  1366. int adj, i, j, optindex, size, result, ret;
  1367. char *arg, msg[MSG_SIZE];
  1369. result = TCL_OK;
  1370. flag = 0;
  1371. if (objc < 3) {
  1372. Tcl_WrongNumArgs(interp, 2, objv, "curs1 curs2 ...");
  1373. return (TCL_ERROR);
  1374. }
  1376. i = 2;
  1377. adj = i;
  1378. while (i < objc) {
  1379. if (Tcl_GetIndexFromObj(interp, objv[i], dbjopts, "option",
  1380.     TCL_EXACT, &optindex) != TCL_OK) {
  1381. result = IS_HELP(objv[i]);
  1382. if (result == TCL_OK)
  1383. return (result);
  1384. result = TCL_OK;
  1385. Tcl_ResetResult(interp);
  1386. break;
  1387. }
  1388. i++;
  1389. switch ((enum dbjopts)optindex) {
  1390. case DBJ_NOSORT:
  1391. flag |= DB_JOIN_NOSORT;
  1392. adj++;
  1393. break;
  1394. }
  1395. }
  1396. if (result != TCL_OK)
  1397. return (result);
  1398. /*
  1399.  * Allocate one more for NULL ptr at end of list.
  1400.  */
  1401. size = sizeof(DBC *) * ((objc - adj) + 1);
  1402. ret = __os_malloc(dbp->dbenv, size, NULL, &listp);
  1403. if (ret != 0) {
  1404. Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
  1405. return (TCL_ERROR);
  1406. }
  1408. memset(listp, 0, size);
  1409. for (j = 0, i = adj; i < objc; i++, j++) {
  1410. arg = Tcl_GetStringFromObj(objv[i], NULL);
  1411. listp[j] = NAME_TO_DBC(arg);
  1412. if (listp[j] == NULL) {
  1413. snprintf(msg, MSG_SIZE,
  1414.     "Join: Invalid cursor: %sn", arg);
  1415. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  1416. result = TCL_ERROR;
  1417. goto out;
  1418. }
  1419. }
  1420. listp[j] = NULL;
  1421. _debug_check();
  1422. ret = dbp->join(dbp, listp, dbcp, flag);
  1423. result = _ReturnSetup(interp, ret, "db join");
  1425. out:
  1426. __os_free(listp, size);
  1427. return (result);
  1428. }
  1430. /*
  1431.  * tcl_db_getjoin --
  1432.  */
  1433. static int
  1434. tcl_DbGetjoin(interp, objc, objv, dbp)
  1435. Tcl_Interp *interp; /* Interpreter */
  1436. int objc; /* How many arguments? */
  1437. Tcl_Obj *CONST objv[]; /* The argument objects */
  1438. DB *dbp; /* Database pointer */
  1439. {
  1440. static char *dbgetjopts[] = {
  1441. "-nosort",
  1442. "-txn",
  1443. NULL
  1444. };
  1445. enum dbgetjopts {
  1446. DBGETJ_NOSORT,
  1447. DBGETJ_TXN
  1448. };
  1449. DB_TXN *txn;
  1450. DB *elemdbp;
  1451. DBC **listp;
  1452. DBC *dbc;
  1453. DBT key, data;
  1454. Tcl_Obj **elemv, *retlist;
  1455. u_int32_t flag;
  1456. int adj, elemc, i, itmp, j, optindex, result, ret, size;
  1457. char *arg, msg[MSG_SIZE];
  1459. result = TCL_OK;
  1460. flag = 0;
  1461. if (objc < 3) {
  1462. Tcl_WrongNumArgs(interp, 2, objv, "{db1 key1} {db2 key2} ...");
  1463. return (TCL_ERROR);
  1464. }
  1466. txn = NULL;
  1467. i = 2;
  1468. adj = i;
  1469. while (i < objc) {
  1470. if (Tcl_GetIndexFromObj(interp, objv[i], dbgetjopts, "option",
  1471.     TCL_EXACT, &optindex) != TCL_OK) {
  1472. result = IS_HELP(objv[i]);
  1473. if (result == TCL_OK)
  1474. return (result);
  1475. result = TCL_OK;
  1476. Tcl_ResetResult(interp);
  1477. break;
  1478. }
  1479. i++;
  1480. switch ((enum dbgetjopts)optindex) {
  1481. case DBGETJ_NOSORT:
  1482. flag |= DB_JOIN_NOSORT;
  1483. adj++;
  1484. break;
  1485. case DBGETJ_TXN:
  1486. if (i == objc) {
  1487. Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
  1488. result = TCL_ERROR;
  1489. break;
  1490. }
  1491. arg = Tcl_GetStringFromObj(objv[i++], NULL);
  1492. txn = NAME_TO_TXN(arg);
  1493. adj += 2;
  1494. if (txn == NULL) {
  1495. snprintf(msg, MSG_SIZE,
  1496.     "GetJoin: Invalid txn: %sn", arg);
  1497. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  1498. result = TCL_ERROR;
  1499. }
  1500. break;
  1501. }
  1502. }
  1503. if (result != TCL_OK)
  1504. return (result);
  1505. size = sizeof(DBC *) * ((objc - adj) + 1);
  1506. ret = __os_malloc(NULL, size, NULL, &listp);
  1507. if (ret != 0) {
  1508. Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
  1509. return (TCL_ERROR);
  1510. }
  1512. memset(listp, 0, size);
  1513. for (j = 0, i = adj; i < objc; i++, j++) {
  1514. /*
  1515.  * Get each sublist as {db key}
  1516.  */
  1517. result = Tcl_ListObjGetElements(interp, objv[i],
  1518.     &elemc, &elemv);
  1519. if (elemc != 2) {
  1520. Tcl_SetResult(interp, "Lists must be {db key}",
  1521.     TCL_STATIC);
  1522. result = TCL_ERROR;
  1523. goto out;
  1524. }
  1525. /*
  1526.  * Get a pointer to that open db.  Then, open a cursor in
  1527.  * that db, and go to the "key" place.
  1528.  */
  1529. elemdbp = NAME_TO_DB(Tcl_GetStringFromObj(elemv[0], NULL));
  1530. if (elemdbp == NULL) {
  1531. snprintf(msg, MSG_SIZE, "Get_join: Invalid db: %sn",
  1532.     Tcl_GetStringFromObj(elemv[0], NULL));
  1533. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  1534. result = TCL_ERROR;
  1535. goto out;
  1536. }
  1537. ret = elemdbp->cursor(elemdbp, txn, &listp[j], 0);
  1538. if ((result = _ReturnSetup(interp, ret, "db cursor")) ==
  1539.     TCL_ERROR)
  1540. goto out;
  1541. memset(&key, 0, sizeof(key));
  1542. memset(&data, 0, sizeof(data));
  1543. key.data = Tcl_GetByteArrayFromObj(elemv[elemc-1], &itmp);
  1544. key.size = itmp;
  1545. ret = (listp[j])->c_get(listp[j], &key, &data, DB_SET);
  1546. if ((result = _ReturnSetup(interp, ret, "db cget")) ==
  1547.     TCL_ERROR)
  1548. goto out;
  1549. }
  1550. listp[j] = NULL;
  1551. _debug_check();
  1552. ret = dbp->join(dbp, listp, &dbc, flag);
  1553. result = _ReturnSetup(interp, ret, "db join");
  1554. if (result == TCL_ERROR)
  1555. goto out;
  1557. retlist = Tcl_NewListObj(0, NULL);
  1558. while (ret == 0 && result == TCL_OK) {
  1559. memset(&key, 0, sizeof(key));
  1560. memset(&data, 0, sizeof(data));
  1561. key.flags |= DB_DBT_MALLOC;
  1562. data.flags |= DB_DBT_MALLOC;
  1563. ret = dbc->c_get(dbc, &key, &data, 0);
  1564. /*
  1565.  * Build up our {name value} sublist
  1566.  */
  1567. if (ret == 0) {
  1568. result = _SetListElem(interp, retlist,
  1569.     key.data, key.size,
  1570.     data.data, data.size);
  1571. __os_free(key.data, key.size);
  1572. __os_free(data.data, data.size);
  1573. }
  1574. }
  1575. dbc->c_close(dbc);
  1576. if (result == TCL_OK)
  1577. Tcl_SetObjResult(interp, retlist);
  1578. out:
  1579. while (j) {
  1580. if (listp[j])
  1581. (listp[j])->c_close(listp[j]);
  1582. j--;
  1583. }
  1584. __os_free(listp, size);
  1585. return (result);
  1586. }
  1588. /*
  1589.  * tcl_DbCount --
  1590.  */
  1591. static int
  1592. tcl_DbCount(interp, objc, objv, dbp)
  1593. Tcl_Interp *interp; /* Interpreter */
  1594. int objc; /* How many arguments? */
  1595. Tcl_Obj *CONST objv[]; /* The argument objects */
  1596. DB *dbp; /* Database pointer */
  1597. {
  1598. Tcl_Obj *res;
  1599. DBC *dbc;
  1600. DBT key, data;
  1601. db_recno_t count, recno;
  1602. int itmp, len, result, ret;
  1604. result = TCL_OK;
  1605. count = 0;
  1606. res = NULL;
  1607. if (objc != 3) {
  1608. Tcl_WrongNumArgs(interp, 2, objv, "key");
  1609. return (TCL_ERROR);
  1610. }
  1612. memset(&key, 0, sizeof(key));
  1614. /*
  1615.  * Get the count for our key.
  1616.  * We do this by getting a cursor for this DB.  Moving the cursor
  1617.  * to the set location, and getting a count on that cursor.
  1618.  */
  1619. ret = 0;
  1620. memset(&key, 0, sizeof(key));
  1621. memset(&data, 0, sizeof(data));
  1622. /*
  1623.  * If it's a queue or recno database, we must make sure to
  1624.  * treat the key as a recno rather than as a byte string.
  1625.  */
  1626. if (dbp->type == DB_RECNO || dbp->type == DB_QUEUE) {
  1627. result = Tcl_GetIntFromObj(interp, objv[2], &itmp);
  1628. recno = itmp;
  1629. if (result == TCL_OK) {
  1630. key.data = &recno;
  1631. key.size = sizeof(db_recno_t);
  1632. } else
  1633. return (result);
  1634. } else {
  1635. key.data = Tcl_GetByteArrayFromObj(objv[2], &len);
  1636. key.size = len;
  1637. }
  1638. _debug_check();
  1639. ret = dbp->cursor(dbp, NULL, &dbc, 0);
  1640. if (ret != 0) {
  1641. result = _ReturnSetup(interp, ret, "db cursor");
  1642. goto out;
  1643. }
  1644. /*
  1645.  * Move our cursor to the key.
  1646.  */
  1647. ret = dbc->c_get(dbc, &key, &data, DB_SET);
  1648. if (ret == DB_NOTFOUND)
  1649. count = 0;
  1650. else {
  1651. ret = dbc->c_count(dbc, &count, 0);
  1652. if (ret != 0) {
  1653. result = _ReturnSetup(interp, ret, "db cursor");
  1654. goto out;
  1655. }
  1656. }
  1657. res = Tcl_NewIntObj(count);
  1658. Tcl_SetObjResult(interp, res);
  1659. out:
  1660. return (result);
  1661. }
  1663. /*
  1664.  * tcl_DbKeyRange --
  1665.  */
  1666. static int
  1667. tcl_DbKeyRange(interp, objc, objv, dbp)
  1668. Tcl_Interp *interp; /* Interpreter */
  1669. int objc; /* How many arguments? */
  1670. Tcl_Obj *CONST objv[]; /* The argument objects */
  1671. DB *dbp; /* Database pointer */
  1672. {
  1673. static char *dbkeyropts[] = {
  1674. "-txn",
  1675. NULL
  1676. };
  1677. enum dbkeyropts {
  1678. DBKEYR_TXN
  1679. };
  1680. DB_TXN *txn;
  1681. DB_KEY_RANGE range;
  1682. DBT key;
  1683. DBTYPE type;
  1684. Tcl_Obj *myobjv[3], *retlist;
  1685. db_recno_t recno;
  1686. u_int32_t flag;
  1687. int i, itmp, myobjc, optindex, result, ret;
  1688. char *arg, msg[MSG_SIZE];
  1690. result = TCL_OK;
  1691. flag = 0;
  1692. if (objc < 3) {
  1693. Tcl_WrongNumArgs(interp, 2, objv, "?-txn id? key");
  1694. return (TCL_ERROR);
  1695. }
  1697. txn = NULL;
  1698. i = 2;
  1699. while (i < objc) {
  1700. if (Tcl_GetIndexFromObj(interp, objv[i], dbkeyropts, "option",
  1701.     TCL_EXACT, &optindex) != TCL_OK) {
  1702. result = IS_HELP(objv[i]);
  1703. if (result == TCL_OK)
  1704. return (result);
  1705. result = TCL_OK;
  1706. Tcl_ResetResult(interp);
  1707. break;
  1708. }
  1709. i++;
  1710. switch ((enum dbkeyropts)optindex) {
  1711. case DBKEYR_TXN:
  1712. if (i == objc) {
  1713. Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
  1714. result = TCL_ERROR;
  1715. break;
  1716. }
  1717. arg = Tcl_GetStringFromObj(objv[i++], NULL);
  1718. txn = NAME_TO_TXN(arg);
  1719. if (txn == NULL) {
  1720. snprintf(msg, MSG_SIZE,
  1721.     "KeyRange: Invalid txn: %sn", arg);
  1722. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  1723. result = TCL_ERROR;
  1724. }
  1725. break;
  1726. }
  1727. }
  1728. if (result != TCL_OK)
  1729. return (result);
  1730. type = dbp->get_type(dbp);
  1731. ret = 0;
  1732. /*
  1733.  * Make sure we have a key.
  1734.  */
  1735. if (i != (objc - 1)) {
  1736. Tcl_WrongNumArgs(interp, 2, objv, "?args? key");
  1737. result = TCL_ERROR;
  1738. goto out;
  1739. }
  1740. memset(&key, 0, sizeof(key));
  1741. if (type == DB_RECNO || type == DB_QUEUE) {
  1742. result = Tcl_GetIntFromObj(interp, objv[i], &itmp);
  1743. recno = itmp;
  1744. if (result == TCL_OK) {
  1745. key.data = &recno;
  1746. key.size = sizeof(db_recno_t);
  1747. } else
  1748. return (result);
  1749. } else {
  1750. key.data = Tcl_GetByteArrayFromObj(objv[i++], &itmp);
  1751. key.size = itmp;
  1752. }
  1753. _debug_check();
  1754. ret = dbp->key_range(dbp, txn, &key, &range, flag);
  1755. result = _ReturnSetup(interp, ret, "db join");
  1756. if (result == TCL_ERROR)
  1757. goto out;
  1759. /*
  1760.  * If we succeeded, set up return list.
  1761.  */
  1762. myobjc = 3;
  1763. myobjv[0] = Tcl_NewDoubleObj(range.less);
  1764. myobjv[1] = Tcl_NewDoubleObj(range.equal);
  1765. myobjv[2] = Tcl_NewDoubleObj(range.greater);
  1766. retlist = Tcl_NewListObj(myobjc, myobjv);
  1767. if (result == TCL_OK)
  1768. Tcl_SetObjResult(interp, retlist);
  1769. out:
  1770. return (result);
  1771. }