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