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

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

MySQL数据库

开发平台：

Visual C++

tcl_compat.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_compat.c,v 11.22 2001/01/11 18:19:55 bostic Exp $";
  12. #endif /* not lint */
  14. #ifndef NO_SYSTEM_INCLUDES
  15. #include <sys/types.h>
  17. #include <fcntl.h>
  18. #include <stdlib.h>
  19. #include <string.h>
  20. #include <tcl.h>
  21. #endif
  23. #define DB_DBM_HSEARCH 1
  25. #include "db_int.h"
  26. #include "tcl_db.h"
  28. /*
  29.  * Prototypes for procedures defined later in this file:
  30.  */
  31. static int mutex_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
  33. /*
  34.  * bdb_HCommand --
  35.  * Implements h* functions.
  36.  *
  37.  * PUBLIC: int bdb_HCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
  38.  */
  39. int
  40. bdb_HCommand(interp, objc, objv)
  41. Tcl_Interp *interp; /* Interpreter */
  42. int objc; /* How many arguments? */
  43. Tcl_Obj *CONST objv[]; /* The argument objects */
  44. {
  45. static char *hcmds[] = {
  46. "hcreate",
  47. "hdestroy",
  48. "hsearch",
  49. NULL
  50. };
  51. enum hcmds {
  52. HHCREATE,
  53. HHDESTROY,
  54. HHSEARCH
  55. };
  56. static char *srchacts[] = {
  57. "enter",
  58. "find",
  59. NULL
  60. };
  61. enum srchacts {
  62. ACT_ENTER,
  63. ACT_FIND
  64. };
  65. ENTRY item, *hres;
  66. ACTION action;
  67. int actindex, cmdindex, nelem, result, ret;
  68. Tcl_Obj *res;
  70. result = TCL_OK;
  71. /*
  72.  * Get the command name index from the object based on the cmds
  73.  * defined above.  This SHOULD NOT fail because we already checked
  74.  * in the 'berkdb' command.
  75.  */
  76. if (Tcl_GetIndexFromObj(interp,
  77.     objv[1], hcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
  78. return (IS_HELP(objv[1]));
  80. res = NULL;
  81. switch ((enum hcmds)cmdindex) {
  82. case HHCREATE:
  83. /*
  84.  * Must be 1 arg, nelem.  Error if not.
  85.  */
  86. if (objc != 3) {
  87. Tcl_WrongNumArgs(interp, 2, objv, "nelem");
  88. return (TCL_ERROR);
  89. }
  90. result = Tcl_GetIntFromObj(interp, objv[2], &nelem);
  91. if (result == TCL_OK) {
  92. _debug_check();
  93. ret = hcreate(nelem) == 0 ? 1: 0;
  94. _ReturnSetup(interp, ret, "hcreate");
  95. }
  96. break;
  97. case HHSEARCH:
  98. /*
  99.  * 3 args for this.  Error if different.
  100.  */
  101. if (objc != 5) {
  102. Tcl_WrongNumArgs(interp, 2, objv, "key data action");
  103. return (TCL_ERROR);
  104. }
  105. item.key = Tcl_GetStringFromObj(objv[2], NULL);
  106. item.data = Tcl_GetStringFromObj(objv[3], NULL);
  107. action = 0;
  108. if (Tcl_GetIndexFromObj(interp, objv[4], srchacts,
  109.     "action", TCL_EXACT, &actindex) != TCL_OK)
  110. return (IS_HELP(objv[4]));
  111. switch ((enum srchacts)actindex) {
  112. case ACT_FIND:
  113. action = FIND;
  114. break;
  115. case ACT_ENTER:
  116. action = ENTER;
  117. break;
  118. }
  119. _debug_check();
  120. hres = hsearch(item, action);
  121. if (hres == NULL)
  122. Tcl_SetResult(interp, "-1", TCL_STATIC);
  123. else if (action == FIND)
  124. Tcl_SetResult(interp, (char *)hres->data, TCL_STATIC);
  125. else
  126. /* action is ENTER */
  127. Tcl_SetResult(interp, "0", TCL_STATIC);
  129. break;
  130. case HHDESTROY:
  131. /*
  132.  * No args for this.  Error if there are some.
  133.  */
  134. if (objc != 2) {
  135. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  136. return (TCL_ERROR);
  137. }
  138. _debug_check();
  139. (void)hdestroy();
  140. res = Tcl_NewIntObj(0);
  141. break;
  142. }
  143. /*
  144.  * Only set result if we have a res.  Otherwise, lower
  145.  * functions have already done so.
  146.  */
  147. if (result == TCL_OK && res)
  148. Tcl_SetObjResult(interp, res);
  149. return (result);
  150. }
  152. /*
  153.  *
  154.  * bdb_NdbmOpen --
  155.  * Opens an ndbm database.
  156.  *
  157.  * PUBLIC: #if DB_DBM_HSEARCH != 0
  158.  * PUBLIC: int bdb_NdbmOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBM **));
  159.  * PUBLIC: #endif
  160.  */
  161. int
  162. bdb_NdbmOpen(interp, objc, objv, dbpp)
  163. Tcl_Interp *interp; /* Interpreter */
  164. int objc; /* How many arguments? */
  165. Tcl_Obj *CONST objv[]; /* The argument objects */
  166. DBM **dbpp; /* Dbm pointer */
  167. {
  168. static char *ndbopen[] = {
  169. "-create",
  170. "-mode",
  171. "-rdonly",
  172. "-truncate",
  173. "--",
  174. NULL
  175. };
  176. enum ndbopen {
  177. NDB_CREATE,
  178. NDB_MODE,
  179. NDB_RDONLY,
  180. NDB_TRUNC,
  181. NDB_ENDARG
  182. };
  184. u_int32_t open_flags;
  185. int endarg, i, mode, optindex, read_only, result;
  186. char *arg, *db;
  188. result = TCL_OK;
  189. open_flags = 0;
  190. endarg = mode = 0;
  191. read_only = 0;
  193. if (objc < 2) {
  194. Tcl_WrongNumArgs(interp, 2, objv, "?args?");
  195. return (TCL_ERROR);
  196. }
  198. /*
  199.  * Get the option name index from the object based on the args
  200.  * defined above.
  201.  */
  202. i = 2;
  203. while (i < objc) {
  204. if (Tcl_GetIndexFromObj(interp, objv[i], ndbopen, "option",
  205.     TCL_EXACT, &optindex) != TCL_OK) {
  206. arg = Tcl_GetStringFromObj(objv[i], NULL);
  207. if (arg[0] == '-') {
  208. result = IS_HELP(objv[i]);
  209. goto error;
  210. } else
  211. Tcl_ResetResult(interp);
  212. break;
  213. }
  214. i++;
  215. switch ((enum ndbopen)optindex) {
  216. case NDB_CREATE:
  217. open_flags |= O_CREAT;
  218. break;
  219. case NDB_RDONLY:
  220. read_only = 1;
  221. break;
  222. case NDB_TRUNC:
  223. open_flags |= O_TRUNC;
  224. break;
  225. case NDB_MODE:
  226. if (i >= objc) {
  227. Tcl_WrongNumArgs(interp, 2, objv,
  228.     "?-mode mode?");
  229. result = TCL_ERROR;
  230. break;
  231. }
  232. /*
  233.  * Don't need to check result here because
  234.  * if TCL_ERROR, the error message is already
  235.  * set up, and we'll bail out below.  If ok,
  236.  * the mode is set and we go on.
  237.  */
  238. result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
  239. break;
  240. case NDB_ENDARG:
  241. endarg = 1;
  242. break;
  243. } /* switch */
  245. /*
  246.  * If, at any time, parsing the args we get an error,
  247.  * bail out and return.
  248.  */
  249. if (result != TCL_OK)
  250. goto error;
  251. if (endarg)
  252. break;
  253. }
  254. if (result != TCL_OK)
  255. goto error;
  257. /*
  258.  * Any args we have left, (better be 0, or 1 left) is a
  259.  * file name.  If we have 0, then an in-memory db.  If
  260.  * there is 1, a db name.
  261.  */
  262. db = NULL;
  263. if (i != objc && i != objc - 1) {
  264. Tcl_WrongNumArgs(interp, 2, objv, "?args? ?file?");
  265. result = TCL_ERROR;
  266. goto error;
  267. }
  268. if (i != objc)
  269. db = Tcl_GetStringFromObj(objv[objc - 1], NULL);
  271. /*
  272.  * When we get here, we have already parsed all of our args
  273.  * and made all our calls to set up the database.  Everything
  274.  * is okay so far, no errors, if we get here.
  275.  *
  276.  * Now open the database.
  277.  */
  278. if (read_only)
  279. open_flags |= O_RDONLY;
  280. else
  281. open_flags |= O_RDWR;
  282. _debug_check();
  283. if ((*dbpp = dbm_open(db, open_flags, mode)) == NULL) {
  284. result = _ReturnSetup(interp, Tcl_GetErrno(), "db open");
  285. goto error;
  286. }
  287. return (TCL_OK);
  289. error:
  290. *dbpp = NULL;
  291. return (result);
  292. }
  294. /*
  295.  * bdb_DbmCommand --
  296.  * Implements "dbm" commands.
  297.  *
  298.  * PUBLIC: #if DB_DBM_HSEARCH != 0
  299.  * PUBLIC: int bdb_DbmCommand
  300.  * PUBLIC:     __P((Tcl_Interp *, int, Tcl_Obj * CONST*, int, DBM *));
  301.  * PUBLIC: #endif
  302.  */
  303. int
  304. bdb_DbmCommand(interp, objc, objv, flag, dbm)
  305. Tcl_Interp *interp; /* Interpreter */
  306. int objc; /* How many arguments? */
  307. Tcl_Obj *CONST objv[]; /* The argument objects */
  308. int flag; /* Which db interface */
  309. DBM *dbm; /* DBM pointer */
  310. {
  311. static char *dbmcmds[] = {
  312. "dbmclose",
  313. "dbminit",
  314. "delete",
  315. "fetch",
  316. "firstkey",
  317. "nextkey",
  318. "store",
  319. NULL
  320. };
  321. enum dbmcmds {
  322. DBMCLOSE,
  323. DBMINIT,
  324. DBMDELETE,
  325. DBMFETCH,
  326. DBMFIRST,
  327. DBMNEXT,
  328. DBMSTORE
  329. };
  330. static char *stflag[] = {
  331. "insert", "replace",
  332. NULL
  333. };
  334. enum stflag {
  335. STINSERT, STREPLACE
  336. };
  337. datum key, data;
  338. int cmdindex, stindex, result, ret;
  339. char *name, *t;
  341. result = TCL_OK;
  342. /*
  343.  * Get the command name index from the object based on the cmds
  344.  * defined above.  This SHOULD NOT fail because we already checked
  345.  * in the 'berkdb' command.
  346.  */
  347. if (Tcl_GetIndexFromObj(interp,
  348.     objv[1], dbmcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
  349. return (IS_HELP(objv[1]));
  351. switch ((enum dbmcmds)cmdindex) {
  352. case DBMCLOSE:
  353. /*
  354.  * No arg for this.  Error if different.
  355.  */
  356. if (objc != 2) {
  357. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  358. return (TCL_ERROR);
  359. }
  360. _debug_check();
  361. if (flag == DBTCL_DBM)
  362. ret = dbmclose();
  363. else {
  364. Tcl_SetResult(interp,
  365.     "Bad interface flag for command", TCL_STATIC);
  366. return (TCL_ERROR);
  367. }
  368. _ReturnSetup(interp, ret, "dbmclose");
  369. break;
  370. case DBMINIT:
  371. /*
  372.  * Must be 1 arg - file.
  373.  */
  374. if (objc != 3) {
  375. Tcl_WrongNumArgs(interp, 2, objv, "file");
  376. return (TCL_ERROR);
  377. }
  378. name = Tcl_GetStringFromObj(objv[2], NULL);
  379. if (flag == DBTCL_DBM)
  380. ret = dbminit(name);
  381. else {
  382. Tcl_SetResult(interp, "Bad interface flag for command",
  383.     TCL_STATIC);
  384. return (TCL_ERROR);
  385. }
  386. _ReturnSetup(interp, ret, "dbminit");
  387. break;
  388. case DBMFETCH:
  389. /*
  390.  * 1 arg for this.  Error if different.
  391.  */
  392. if (objc != 3) {
  393. Tcl_WrongNumArgs(interp, 2, objv, "key");
  394. return (TCL_ERROR);
  395. }
  396. key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
  397. _debug_check();
  398. if (flag == DBTCL_DBM)
  399. data = fetch(key);
  400. else if (flag == DBTCL_NDBM)
  401. data = dbm_fetch(dbm, key);
  402. else {
  403. Tcl_SetResult(interp,
  404.     "Bad interface flag for command", TCL_STATIC);
  405. return (TCL_ERROR);
  406. }
  407. if (data.dptr == NULL ||
  408.     (ret = __os_malloc(NULL, data.dsize + 1, NULL, &t)) != 0)
  409. Tcl_SetResult(interp, "-1", TCL_STATIC);
  410. else {
  411. memcpy(t, data.dptr, data.dsize);
  412. t[data.dsize] = '';
  413. Tcl_SetResult(interp, t, TCL_VOLATILE);
  414. __os_free(t, data.dsize + 1);
  415. }
  416. break;
  417. case DBMSTORE:
  418. /*
  419.  * 2 args for this.  Error if different.
  420.  */
  421. if (objc != 4 && flag == DBTCL_DBM) {
  422. Tcl_WrongNumArgs(interp, 2, objv, "key data");
  423. return (TCL_ERROR);
  424. }
  425. if (objc != 5 && flag == DBTCL_NDBM) {
  426. Tcl_WrongNumArgs(interp, 2, objv, "key data action");
  427. return (TCL_ERROR);
  428. }
  429. key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
  430. data.dptr =
  431.     (char *)Tcl_GetByteArrayFromObj(objv[3], &data.dsize);
  432. _debug_check();
  433. if (flag == DBTCL_DBM)
  434. ret = store(key, data);
  435. else if (flag == DBTCL_NDBM) {
  436. if (Tcl_GetIndexFromObj(interp, objv[4], stflag,
  437.     "flag", TCL_EXACT, &stindex) != TCL_OK)
  438. return (IS_HELP(objv[4]));
  439. switch ((enum stflag)stindex) {
  440. case STINSERT:
  441. flag = DBM_INSERT;
  442. break;
  443. case STREPLACE:
  444. flag = DBM_REPLACE;
  445. break;
  446. }
  447. ret = dbm_store(dbm, key, data, flag);
  448. } else {
  449. Tcl_SetResult(interp,
  450.     "Bad interface flag for command", TCL_STATIC);
  451. return (TCL_ERROR);
  452. }
  453. _ReturnSetup(interp, ret, "store");
  454. break;
  455. case DBMDELETE:
  456. /*
  457.  * 1 arg for this.  Error if different.
  458.  */
  459. if (objc != 3) {
  460. Tcl_WrongNumArgs(interp, 2, objv, "key");
  461. return (TCL_ERROR);
  462. }
  463. key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
  464. _debug_check();
  465. if (flag == DBTCL_DBM)
  466. ret = delete(key);
  467. else if (flag == DBTCL_NDBM)
  468. ret = dbm_delete(dbm, key);
  469. else {
  470. Tcl_SetResult(interp,
  471.     "Bad interface flag for command", TCL_STATIC);
  472. return (TCL_ERROR);
  473. }
  474. _ReturnSetup(interp, ret, "delete");
  475. break;
  476. case DBMFIRST:
  477. /*
  478.  * No arg for this.  Error if different.
  479.  */
  480. if (objc != 2) {
  481. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  482. return (TCL_ERROR);
  483. }
  484. _debug_check();
  485. if (flag == DBTCL_DBM)
  486. key = firstkey();
  487. else if (flag == DBTCL_NDBM)
  488. key = dbm_firstkey(dbm);
  489. else {
  490. Tcl_SetResult(interp,
  491.     "Bad interface flag for command", TCL_STATIC);
  492. return (TCL_ERROR);
  493. }
  494. if (key.dptr == NULL ||
  495.     (ret = __os_malloc(NULL, key.dsize + 1, NULL, &t)) != 0)
  496. Tcl_SetResult(interp, "-1", TCL_STATIC);
  497. else {
  498. memcpy(t, key.dptr, key.dsize);
  499. t[key.dsize] = '';
  500. Tcl_SetResult(interp, t, TCL_VOLATILE);
  501. __os_free(t, key.dsize + 1);
  502. }
  503. break;
  504. case DBMNEXT:
  505. /*
  506.  * 0 or 1 arg for this.  Error if different.
  507.  */
  508. _debug_check();
  509. if (flag == DBTCL_DBM) {
  510. if (objc != 3) {
  511. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  512. return (TCL_ERROR);
  513. }
  514. key.dptr = (char *)
  515.     Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
  516. data = nextkey(key);
  517. } else if (flag == DBTCL_NDBM) {
  518. if (objc != 2) {
  519. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  520. return (TCL_ERROR);
  521. }
  522. data = dbm_nextkey(dbm);
  523. } else {
  524. Tcl_SetResult(interp,
  525.     "Bad interface flag for command", TCL_STATIC);
  526. return (TCL_ERROR);
  527. }
  528. if (data.dptr == NULL ||
  529.     (ret = __os_malloc(NULL, data.dsize + 1, NULL, &t)) != 0)
  530. Tcl_SetResult(interp, "-1", TCL_STATIC);
  531. else {
  532. memcpy(t, data.dptr, data.dsize);
  533. t[data.dsize] = '';
  534. Tcl_SetResult(interp, t, TCL_VOLATILE);
  535. __os_free(t, data.dsize + 1);
  536. }
  537. break;
  538. }
  539. return (result);
  540. }
  542. /*
  543.  * ndbm_Cmd --
  544.  * Implements the "ndbm" widget.
  545.  *
  546.  * PUBLIC: int ndbm_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
  547.  */
  548. int
  549. ndbm_Cmd(clientData, interp, objc, objv)
  550. ClientData clientData; /* DB handle */
  551. Tcl_Interp *interp; /* Interpreter */
  552. int objc; /* How many arguments? */
  553. Tcl_Obj *CONST objv[]; /* The argument objects */
  554. {
  555. static char *ndbcmds[] = {
  556. "clearerr",
  557. "close",
  558. "delete",
  559. "dirfno",
  560. "error",
  561. "fetch",
  562. "firstkey",
  563. "nextkey",
  564. "pagfno",
  565. "rdonly",
  566. "store",
  567. NULL
  568. };
  569. enum ndbcmds {
  570. NDBCLRERR,
  571. NDBCLOSE,
  572. NDBDELETE,
  573. NDBDIRFNO,
  574. NDBERR,
  575. NDBFETCH,
  576. NDBFIRST,
  577. NDBNEXT,
  578. NDBPAGFNO,
  579. NDBRDONLY,
  580. NDBSTORE
  581. };
  582. DBM *dbp;
  583. DBTCL_INFO *dbip;
  584. Tcl_Obj *res;
  585. int cmdindex, result, ret;
  587. Tcl_ResetResult(interp);
  588. dbp = (DBM *)clientData;
  589. dbip = _PtrToInfo((void *)dbp);
  590. result = TCL_OK;
  591. if (objc <= 1) {
  592. Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
  593. return (TCL_ERROR);
  594. }
  595. if (dbp == NULL) {
  596. Tcl_SetResult(interp, "NULL db pointer", TCL_STATIC);
  597. return (TCL_ERROR);
  598. }
  599. if (dbip == NULL) {
  600. Tcl_SetResult(interp, "NULL db info pointer", TCL_STATIC);
  601. return (TCL_ERROR);
  602. }
  604. /*
  605.  * Get the command name index from the object based on the dbcmds
  606.  * defined above.
  607.  */
  608. if (Tcl_GetIndexFromObj(interp,
  609.     objv[1], ndbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
  610. return (IS_HELP(objv[1]));
  612. res = NULL;
  613. switch ((enum ndbcmds)cmdindex) {
  614. case NDBCLOSE:
  615. _debug_check();
  616. dbm_close(dbp);
  617. (void)Tcl_DeleteCommand(interp, dbip->i_name);
  618. _DeleteInfo(dbip);
  619. res = Tcl_NewIntObj(0);
  620. break;
  621. case NDBDELETE:
  622. case NDBFETCH:
  623. case NDBFIRST:
  624. case NDBNEXT:
  625. case NDBSTORE:
  626. result = bdb_DbmCommand(interp, objc, objv, DBTCL_NDBM, dbp);
  627. break;
  628. case NDBCLRERR:
  629. /*
  630.  * No args for this.  Error if there are some.
  631.  */
  632. if (objc > 2) {
  633. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  634. return (TCL_ERROR);
  635. }
  636. _debug_check();
  637. ret = dbm_clearerr(dbp);
  638. if (ret)
  639. _ReturnSetup(interp, ret, "clearerr");
  640. else
  641. res = Tcl_NewIntObj(ret);
  642. break;
  643. case NDBDIRFNO:
  644. /*
  645.  * No args for this.  Error if there are some.
  646.  */
  647. if (objc > 2) {
  648. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  649. return (TCL_ERROR);
  650. }
  651. _debug_check();
  652. ret = dbm_dirfno(dbp);
  653. res = Tcl_NewIntObj(ret);
  654. break;
  655. case NDBPAGFNO:
  656. /*
  657.  * No args for this.  Error if there are some.
  658.  */
  659. if (objc > 2) {
  660. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  661. return (TCL_ERROR);
  662. }
  663. _debug_check();
  664. ret = dbm_pagfno(dbp);
  665. res = Tcl_NewIntObj(ret);
  666. break;
  667. case NDBERR:
  668. /*
  669.  * No args for this.  Error if there are some.
  670.  */
  671. if (objc > 2) {
  672. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  673. return (TCL_ERROR);
  674. }
  675. _debug_check();
  676. ret = dbm_error(dbp);
  677. Tcl_SetErrno(ret);
  678. Tcl_SetResult(interp, Tcl_PosixError(interp), TCL_STATIC);
  679. break;
  680. case NDBRDONLY:
  681. /*
  682.  * No args for this.  Error if there are some.
  683.  */
  684. if (objc > 2) {
  685. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  686. return (TCL_ERROR);
  687. }
  688. _debug_check();
  689. ret = dbm_rdonly(dbp);
  690. if (ret)
  691. _ReturnSetup(interp, ret, "rdonly");
  692. else
  693. res = Tcl_NewIntObj(ret);
  694. break;
  695. }
  696. /*
  697.  * Only set result if we have a res.  Otherwise, lower
  698.  * functions have already done so.
  699.  */
  700. if (result == TCL_OK && res)
  701. Tcl_SetObjResult(interp, res);
  702. return (result);
  703. }
  705. /*
  706.  * bdb_RandCommand --
  707.  * Implements rand* functions.
  708.  *
  709.  * PUBLIC: int bdb_RandCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
  710.  */
  711. int
  712. bdb_RandCommand(interp, objc, objv)
  713. Tcl_Interp *interp; /* Interpreter */
  714. int objc; /* How many arguments? */
  715. Tcl_Obj *CONST objv[]; /* The argument objects */
  716. {
  717. static char *rcmds[] = {
  718. "rand", "random_int", "srand",
  719. NULL
  720. };
  721. enum rcmds {
  722. RRAND, RRAND_INT, RSRAND
  723. };
  724. long t;
  725. int cmdindex, hi, lo, result, ret;
  726. Tcl_Obj *res;
  727. char msg[MSG_SIZE];
  729. result = TCL_OK;
  730. /*
  731.  * Get the command name index from the object based on the cmds
  732.  * defined above.  This SHOULD NOT fail because we already checked
  733.  * in the 'berkdb' command.
  734.  */
  735. if (Tcl_GetIndexFromObj(interp,
  736.     objv[1], rcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
  737. return (IS_HELP(objv[1]));
  739. res = NULL;
  740. switch ((enum rcmds)cmdindex) {
  741. case RRAND:
  742. /*
  743.  * Must be 0 args.  Error if different.
  744.  */
  745. if (objc != 2) {
  746. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  747. return (TCL_ERROR);
  748. }
  749. ret = rand();
  750. res = Tcl_NewIntObj(ret);
  751. break;
  752. case RRAND_INT:
  753. /*
  754.  * Must be 4 args.  Error if different.
  755.  */
  756. if (objc != 4) {
  757. Tcl_WrongNumArgs(interp, 2, objv, "lo hi");
  758. return (TCL_ERROR);
  759. }
  760. result = Tcl_GetIntFromObj(interp, objv[2], &lo);
  761. if (result != TCL_OK)
  762. break;
  763. result = Tcl_GetIntFromObj(interp, objv[3], &hi);
  764. if (result == TCL_OK) {
  765. #ifndef RAND_MAX
  766. #define RAND_MAX 0x7fffffff
  767. #endif
  768. t = rand();
  769. if (t > RAND_MAX) {
  770. snprintf(msg, MSG_SIZE,
  771.     "Max random is higher than %ldn",
  772.     (long)RAND_MAX);
  773. Tcl_SetResult(interp, msg, TCL_VOLATILE);
  774. result = TCL_ERROR;
  775. break;
  776. }
  777. _debug_check();
  778. ret = (int)(((double)t / ((double)(RAND_MAX) + 1)) *
  779.     (hi - lo + 1));
  780. ret += lo;
  781. res = Tcl_NewIntObj(ret);
  782. }
  783. break;
  784. case RSRAND:
  785. /*
  786.  * Must be 1 arg.  Error if different.
  787.  */
  788. if (objc != 3) {
  789. Tcl_WrongNumArgs(interp, 2, objv, "seed");
  790. return (TCL_ERROR);
  791. }
  792. result = Tcl_GetIntFromObj(interp, objv[2], &lo);
  793. if (result == TCL_OK) {
  794. srand((u_int)lo);
  795. res = Tcl_NewIntObj(0);
  796. }
  797. break;
  798. }
  799. /*
  800.  * Only set result if we have a res.  Otherwise, lower
  801.  * functions have already done so.
  802.  */
  803. if (result == TCL_OK && res)
  804. Tcl_SetObjResult(interp, res);
  805. return (result);
  806. }
  808. /*
  809.  *
  810.  * tcl_Mutex --
  811.  * Opens an env mutex.
  812.  *
  813.  * PUBLIC: int tcl_Mutex __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *,
  814.  * PUBLIC:    DBTCL_INFO *));
  815.  */
  816. int
  817. tcl_Mutex(interp, objc, objv, envp, envip)
  818. Tcl_Interp *interp;             /* Interpreter */
  819. int objc;                       /* How many arguments? */
  820. Tcl_Obj *CONST objv[];          /* The argument objects */
  821. DB_ENV *envp; /* Environment pointer */
  822. DBTCL_INFO *envip; /* Info pointer */
  823. {
  824. DBTCL_INFO *ip;
  825. Tcl_Obj *res;
  826. _MUTEX_DATA *md;
  827. int i, mode, nitems, result, ret;
  828. char newname[MSG_SIZE];
  830. md = NULL;
  831. result = TCL_OK;
  832. mode = nitems = ret = 0;
  833. memset(newname, 0, MSG_SIZE);
  835. if (objc != 4) {
  836. Tcl_WrongNumArgs(interp, 2, objv, "mode nitems");
  837. return (TCL_ERROR);
  838. }
  839. result = Tcl_GetIntFromObj(interp, objv[2], &mode);
  840. if (result != TCL_OK)
  841. return (TCL_ERROR);
  842. result = Tcl_GetIntFromObj(interp, objv[3], &nitems);
  843. if (result != TCL_OK)
  844. return (TCL_ERROR);
  846. snprintf(newname, sizeof(newname),
  847.     "%s.mutex%d", envip->i_name, envip->i_envmutexid);
  848. ip = _NewInfo(interp, NULL, newname, I_MUTEX);
  849. if (ip == NULL) {
  850. Tcl_SetResult(interp, "Could not set up info",
  851.     TCL_STATIC);
  852. return (TCL_ERROR);
  853. }
  854. /*
  855.  * Set up mutex.
  856.  */
  857. /*
  858.  * Map in the region.
  859.  *
  860.  * XXX
  861.  * We don't bother doing this "right", i.e., using the shalloc
  862.  * functions, just grab some memory knowing that it's correctly
  863.  * aligned.
  864.  */
  865. _debug_check();
  866. if (__os_calloc(NULL, 1, sizeof(_MUTEX_DATA), &md) != 0)
  867. goto posixout;
  868. md->env = envp;
  869. md->n_mutex = nitems;
  870. md->size = sizeof(_MUTEX_ENTRY) * nitems;
  872. md->reginfo.type = REGION_TYPE_MUTEX;
  873. md->reginfo.id = INVALID_REGION_TYPE;
  874. md->reginfo.mode = mode;
  875. md->reginfo.flags = REGION_CREATE_OK | REGION_JOIN_OK;
  876. if ((ret = __db_r_attach(envp, &md->reginfo, md->size)) != 0)
  877. goto posixout;
  878. md->marray = md->reginfo.addr;
  880. /* Initialize a created region. */
  881. if (F_ISSET(&md->reginfo, REGION_CREATE))
  882. for (i = 0; i < nitems; i++) {
  883. md->marray[i].val = 0;
  884. if ((ret =
  885.     __db_mutex_init(envp, &md->marray[i].m, i, 0)) != 0)
  886. goto posixout;
  887. }
  888. R_UNLOCK(envp, &md->reginfo);
  890. /*
  891.  * Success.  Set up return.  Set up new info
  892.  * and command widget for this mutex.
  893.  */
  894. envip->i_envmutexid++;
  895. ip->i_parent = envip;
  896. _SetInfoData(ip, md);
  897. Tcl_CreateObjCommand(interp, newname,
  898.     (Tcl_ObjCmdProc *)mutex_Cmd, (ClientData)md, NULL);
  899. res = Tcl_NewStringObj(newname, strlen(newname));
  900. Tcl_SetObjResult(interp, res);
  902. return (TCL_OK);
  904. posixout:
  905. if (ret > 0)
  906. Tcl_PosixError(interp);
  907. result = _ReturnSetup(interp, ret, "mutex");
  908. _DeleteInfo(ip);
  910. if (md != NULL) {
  911. if (md->reginfo.addr != NULL)
  912. (void)__db_r_detach(md->env,
  913.     &md->reginfo, F_ISSET(&md->reginfo, REGION_CREATE));
  914. __os_free(md, sizeof(*md));
  915. }
  916. return (result);
  917. }
  919. /*
  920.  * mutex_Cmd --
  921.  * Implements the "mutex" widget.
  922.  */
  923. static int
  924. mutex_Cmd(clientData, interp, objc, objv)
  925. ClientData clientData;          /* Mutex handle */
  926. Tcl_Interp *interp;             /* Interpreter */
  927. int objc;                       /* How many arguments? */
  928. Tcl_Obj *CONST objv[];          /* The argument objects */
  929. {
  930. static char *mxcmds[] = {
  931. "close",
  932. "get",
  933. "getval",
  934. "release",
  935. "setval",
  936. NULL
  937. };
  938. enum mxcmds {
  939. MXCLOSE,
  940. MXGET,
  941. MXGETVAL,
  942. MXRELE,
  943. MXSETVAL
  944. };
  945. DB_ENV *dbenv;
  946. DBTCL_INFO *envip, *mpip;
  947. _MUTEX_DATA *mp;
  948. Tcl_Obj *res;
  949. int cmdindex, id, result, newval;
  951. Tcl_ResetResult(interp);
  952. mp = (_MUTEX_DATA *)clientData;
  953. mpip = _PtrToInfo((void *)mp);
  954. envip = mpip->i_parent;
  955. dbenv = envip->i_envp;
  956. result = TCL_OK;
  958. if (mp == NULL) {
  959. Tcl_SetResult(interp, "NULL mp pointer", TCL_STATIC);
  960. return (TCL_ERROR);
  961. }
  962. if (mpip == NULL) {
  963. Tcl_SetResult(interp, "NULL mp info pointer", TCL_STATIC);
  964. return (TCL_ERROR);
  965. }
  967. /*
  968.  * Get the command name index from the object based on the dbcmds
  969.  * defined above.
  970.  */
  971. if (Tcl_GetIndexFromObj(interp,
  972.     objv[1], mxcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
  973. return (IS_HELP(objv[1]));
  975. res = NULL;
  976. switch ((enum mxcmds)cmdindex) {
  977. case MXCLOSE:
  978. if (objc != 2) {
  979. Tcl_WrongNumArgs(interp, 1, objv, NULL);
  980. return (TCL_ERROR);
  981. }
  982. _debug_check();
  983. (void)__db_r_detach(mp->env, &mp->reginfo, 0);
  984. res = Tcl_NewIntObj(0);
  985. (void)Tcl_DeleteCommand(interp, mpip->i_name);
  986. _DeleteInfo(mpip);
  987. __os_free(mp, sizeof(*mp));
  988. break;
  989. case MXRELE:
  990. /*
  991.  * Check for 1 arg.  Error if different.
  992.  */
  993. if (objc != 3) {
  994. Tcl_WrongNumArgs(interp, 2, objv, "id");
  995. return (TCL_ERROR);
  996. }
  997. result = Tcl_GetIntFromObj(interp, objv[2], &id);
  998. if (result != TCL_OK)
  999. break;
  1000. MUTEX_UNLOCK(dbenv, &mp->marray[id].m);
  1001. res = Tcl_NewIntObj(0);
  1002. break;
  1003. case MXGET:
  1004. /*
  1005.  * Check for 1 arg.  Error if different.
  1006.  */
  1007. if (objc != 3) {
  1008. Tcl_WrongNumArgs(interp, 2, objv, "id");
  1009. return (TCL_ERROR);
  1010. }
  1011. result = Tcl_GetIntFromObj(interp, objv[2], &id);
  1012. if (result != TCL_OK)
  1013. break;
  1014. MUTEX_LOCK(dbenv, &mp->marray[id].m, mp->env->lockfhp);
  1015. res = Tcl_NewIntObj(0);
  1016. break;
  1017. case MXGETVAL:
  1018. /*
  1019.  * Check for 1 arg.  Error if different.
  1020.  */
  1021. if (objc != 3) {
  1022. Tcl_WrongNumArgs(interp, 2, objv, "id");
  1023. return (TCL_ERROR);
  1024. }
  1025. result = Tcl_GetIntFromObj(interp, objv[2], &id);
  1026. if (result != TCL_OK)
  1027. break;
  1028. res = Tcl_NewIntObj(mp->marray[id].val);
  1029. break;
  1030. case MXSETVAL:
  1031. /*
  1032.  * Check for 2 args.  Error if different.
  1033.  */
  1034. if (objc != 4) {
  1035. Tcl_WrongNumArgs(interp, 2, objv, "id val");
  1036. return (TCL_ERROR);
  1037. }
  1038. result = Tcl_GetIntFromObj(interp, objv[2], &id);
  1039. if (result != TCL_OK)
  1040. break;
  1041. result = Tcl_GetIntFromObj(interp, objv[3], &newval);
  1042. if (result != TCL_OK)
  1043. break;
  1044. mp->marray[id].val = newval;
  1045. res = Tcl_NewIntObj(0);
  1046. break;
  1047. }
  1048. /*
  1049.  * Only set result if we have a res.  Otherwise, lower
  1050.  * functions have already done so.
  1051.  */
  1052. if (result == TCL_OK && res)
  1053. Tcl_SetObjResult(interp, res);
  1054. return (result);
  1055. }