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

源码开发语言/平台
当前位置：首页 > 源码/资料 > 数据库系统 > MySQL数据库 > 查看源码
tcl_compat.c
资源名称：mysql-4.1.16-win-src.zip　[点击查看]
上传用户：romrleung
上传日期：2022-05-23
资源大小：18897k
文件大小：16k
源码类别：

MySQL数据库

开发平台：

Visual C++

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