1/*- 2 * See the file LICENSE for redistribution information. 3 * 4 * Copyright (c) 1999,2008 Oracle. All rights reserved. 5 * 6 * $Id: tcl_internal.c,v 12.28 2008/01/08 20:58:52 bostic Exp $ 7 */ 8 9#include "db_config.h" 10 11#include "db_int.h" 12#ifdef HAVE_SYSTEM_INCLUDE_FILES 13#include <tcl.h> 14#endif 15#include "dbinc/tcl_db.h" 16#include "dbinc/db_page.h" 17#include "dbinc/db_am.h" 18 19/* 20 * 21 * internal.c -- 22 * 23 * This file contains internal functions we need to maintain 24 * state for our Tcl interface. 25 * 26 * NOTE: This all uses a linear linked list. If we end up with 27 * too many info structs such that this is a performance hit, it 28 * should be redone using hashes or a list per type. The assumption 29 * is that the user won't have more than a few dozen info structs 30 * in operation at any given point in time. Even a complicated 31 * application with a few environments, nested transactions, locking, 32 * and several databases open, using cursors should not have a 33 * negative performance impact, in terms of searching the list to 34 * get/manipulate the info structure. 35 */ 36 37#define GLOB_CHAR(c) ((c) == '*' || (c) == '?') 38 39/* 40 * PUBLIC: DBTCL_INFO *_NewInfo __P((Tcl_Interp *, 41 * PUBLIC: void *, char *, enum INFOTYPE)); 42 * 43 * _NewInfo -- 44 * 45 * This function will create a new info structure and fill it in 46 * with the name and pointer, id and type. 47 */ 48DBTCL_INFO * 49_NewInfo(interp, anyp, name, type) 50 Tcl_Interp *interp; 51 void *anyp; 52 char *name; 53 enum INFOTYPE type; 54{ 55 DBTCL_INFO *p; 56 int ret; 57 58 if ((ret = __os_calloc(NULL, sizeof(DBTCL_INFO), 1, &p)) != 0) { 59 Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); 60 return (NULL); 61 } 62 63 if ((ret = __os_strdup(NULL, name, &p->i_name)) != 0) { 64 Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC); 65 __os_free(NULL, p); 66 return (NULL); 67 } 68 p->i_interp = interp; 69 p->i_anyp = anyp; 70 p->i_type = type; 71 72 LIST_INSERT_HEAD(&__db_infohead, p, entries); 73 return (p); 74} 75 76/* 77 * PUBLIC: void *_NameToPtr __P((CONST char *)); 78 */ 79void * 80_NameToPtr(name) 81 CONST char *name; 82{ 83 DBTCL_INFO *p; 84 85 LIST_FOREACH(p, &__db_infohead, entries) 86 if (strcmp(name, p->i_name) == 0) 87 return (p->i_anyp); 88 return (NULL); 89} 90 91/* 92 * PUBLIC: DBTCL_INFO *_PtrToInfo __P((CONST void *)); 93 */ 94DBTCL_INFO * 95_PtrToInfo(ptr) 96 CONST void *ptr; 97{ 98 DBTCL_INFO *p; 99 100 LIST_FOREACH(p, &__db_infohead, entries) 101 if (p->i_anyp == ptr) 102 return (p); 103 return (NULL); 104} 105 106/* 107 * PUBLIC: DBTCL_INFO *_NameToInfo __P((CONST char *)); 108 */ 109DBTCL_INFO * 110_NameToInfo(name) 111 CONST char *name; 112{ 113 DBTCL_INFO *p; 114 115 LIST_FOREACH(p, &__db_infohead, entries) 116 if (strcmp(name, p->i_name) == 0) 117 return (p); 118 return (NULL); 119} 120 121/* 122 * PUBLIC: void _SetInfoData __P((DBTCL_INFO *, void *)); 123 */ 124void 125_SetInfoData(p, data) 126 DBTCL_INFO *p; 127 void *data; 128{ 129 if (p == NULL) 130 return; 131 p->i_anyp = data; 132 return; 133} 134 135/* 136 * PUBLIC: void _DeleteInfo __P((DBTCL_INFO *)); 137 */ 138void 139_DeleteInfo(p) 140 DBTCL_INFO *p; 141{ 142 if (p == NULL) 143 return; 144 LIST_REMOVE(p, entries); 145 if (p->i_lockobj.data != NULL) 146 __os_free(NULL, p->i_lockobj.data); 147 if (p->i_err != NULL && p->i_err != stderr && p->i_err != stdout) { 148 (void)fclose(p->i_err); 149 p->i_err = NULL; 150 } 151 if (p->i_errpfx != NULL) 152 __os_free(NULL, p->i_errpfx); 153 if (p->i_compare != NULL) { 154 Tcl_DecrRefCount(p->i_compare); 155 } 156 if (p->i_dupcompare != NULL) { 157 Tcl_DecrRefCount(p->i_dupcompare); 158 } 159 if (p->i_hashproc != NULL) { 160 Tcl_DecrRefCount(p->i_hashproc); 161 } 162 if (p->i_second_call != NULL) { 163 Tcl_DecrRefCount(p->i_second_call); 164 } 165 if (p->i_rep_eid != NULL) { 166 Tcl_DecrRefCount(p->i_rep_eid); 167 } 168 if (p->i_rep_send != NULL) { 169 Tcl_DecrRefCount(p->i_rep_send); 170 } 171 if (p->i_event != NULL) { 172 Tcl_DecrRefCount(p->i_event); 173 } 174 __os_free(NULL, p->i_name); 175 __os_free(NULL, p); 176 177 return; 178} 179 180/* 181 * PUBLIC: int _SetListElem __P((Tcl_Interp *, 182 * PUBLIC: Tcl_Obj *, void *, u_int32_t, void *, u_int32_t)); 183 */ 184int 185_SetListElem(interp, list, elem1, e1cnt, elem2, e2cnt) 186 Tcl_Interp *interp; 187 Tcl_Obj *list; 188 void *elem1, *elem2; 189 u_int32_t e1cnt, e2cnt; 190{ 191 Tcl_Obj *myobjv[2], *thislist; 192 int myobjc; 193 194 myobjc = 2; 195 myobjv[0] = Tcl_NewByteArrayObj((u_char *)elem1, (int)e1cnt); 196 myobjv[1] = Tcl_NewByteArrayObj((u_char *)elem2, (int)e2cnt); 197 thislist = Tcl_NewListObj(myobjc, myobjv); 198 if (thislist == NULL) 199 return (TCL_ERROR); 200 return (Tcl_ListObjAppendElement(interp, list, thislist)); 201 202} 203 204/* 205 * PUBLIC: int _SetListElemInt __P((Tcl_Interp *, Tcl_Obj *, void *, long)); 206 */ 207int 208_SetListElemInt(interp, list, elem1, elem2) 209 Tcl_Interp *interp; 210 Tcl_Obj *list; 211 void *elem1; 212 long elem2; 213{ 214 Tcl_Obj *myobjv[2], *thislist; 215 int myobjc; 216 217 myobjc = 2; 218 myobjv[0] = 219 Tcl_NewByteArrayObj((u_char *)elem1, (int)strlen((char *)elem1)); 220 myobjv[1] = Tcl_NewLongObj(elem2); 221 thislist = Tcl_NewListObj(myobjc, myobjv); 222 if (thislist == NULL) 223 return (TCL_ERROR); 224 return (Tcl_ListObjAppendElement(interp, list, thislist)); 225} 226 227/* 228 * Don't compile this code if we don't have sequences compiled into the DB 229 * library, it's likely because we don't have a 64-bit type, and trying to 230 * use int64_t is going to result in syntax errors. 231 */ 232#ifdef HAVE_64BIT_TYPES 233/* 234 * PUBLIC: int _SetListElemWideInt __P((Tcl_Interp *, 235 * PUBLIC: Tcl_Obj *, void *, int64_t)); 236 */ 237int 238_SetListElemWideInt(interp, list, elem1, elem2) 239 Tcl_Interp *interp; 240 Tcl_Obj *list; 241 void *elem1; 242 int64_t elem2; 243{ 244 Tcl_Obj *myobjv[2], *thislist; 245 int myobjc; 246 247 myobjc = 2; 248 myobjv[0] = 249 Tcl_NewByteArrayObj((u_char *)elem1, (int)strlen((char *)elem1)); 250 myobjv[1] = Tcl_NewWideIntObj(elem2); 251 thislist = Tcl_NewListObj(myobjc, myobjv); 252 if (thislist == NULL) 253 return (TCL_ERROR); 254 return (Tcl_ListObjAppendElement(interp, list, thislist)); 255} 256#endif /* HAVE_64BIT_TYPES */ 257 258/* 259 * PUBLIC: int _SetListRecnoElem __P((Tcl_Interp *, Tcl_Obj *, 260 * PUBLIC: db_recno_t, u_char *, u_int32_t)); 261 */ 262int 263_SetListRecnoElem(interp, list, elem1, elem2, e2size) 264 Tcl_Interp *interp; 265 Tcl_Obj *list; 266 db_recno_t elem1; 267 u_char *elem2; 268 u_int32_t e2size; 269{ 270 Tcl_Obj *myobjv[2], *thislist; 271 int myobjc; 272 273 myobjc = 2; 274 myobjv[0] = Tcl_NewWideIntObj((Tcl_WideInt)elem1); 275 myobjv[1] = Tcl_NewByteArrayObj(elem2, (int)e2size); 276 thislist = Tcl_NewListObj(myobjc, myobjv); 277 if (thislist == NULL) 278 return (TCL_ERROR); 279 return (Tcl_ListObjAppendElement(interp, list, thislist)); 280 281} 282 283/* 284 * _Set3DBTList -- 285 * This is really analogous to both _SetListElem and 286 * _SetListRecnoElem--it's used for three-DBT lists returned by 287 * DB->pget and DBC->pget(). We'd need a family of four functions 288 * to handle all the recno/non-recno cases, however, so we make 289 * this a little more aware of the internals and do the logic inside. 290 * 291 * XXX 292 * One of these days all these functions should probably be cleaned up 293 * to eliminate redundancy and bring them into the standard DB 294 * function namespace. 295 * 296 * PUBLIC: int _Set3DBTList __P((Tcl_Interp *, Tcl_Obj *, DBT *, int, 297 * PUBLIC: DBT *, int, DBT *)); 298 */ 299int 300_Set3DBTList(interp, list, elem1, is1recno, elem2, is2recno, elem3) 301 Tcl_Interp *interp; 302 Tcl_Obj *list; 303 DBT *elem1, *elem2, *elem3; 304 int is1recno, is2recno; 305{ 306 307 Tcl_Obj *myobjv[3], *thislist; 308 309 if (is1recno) 310 myobjv[0] = Tcl_NewWideIntObj( 311 (Tcl_WideInt)*(db_recno_t *)elem1->data); 312 else 313 myobjv[0] = Tcl_NewByteArrayObj( 314 (u_char *)elem1->data, (int)elem1->size); 315 316 if (is2recno) 317 myobjv[1] = Tcl_NewWideIntObj( 318 (Tcl_WideInt)*(db_recno_t *)elem2->data); 319 else 320 myobjv[1] = Tcl_NewByteArrayObj( 321 (u_char *)elem2->data, (int)elem2->size); 322 323 myobjv[2] = Tcl_NewByteArrayObj( 324 (u_char *)elem3->data, (int)elem3->size); 325 326 thislist = Tcl_NewListObj(3, myobjv); 327 328 if (thislist == NULL) 329 return (TCL_ERROR); 330 return (Tcl_ListObjAppendElement(interp, list, thislist)); 331} 332 333/* 334 * _SetMultiList -- build a list for return from multiple get. 335 * 336 * PUBLIC: int _SetMultiList __P((Tcl_Interp *, 337 * PUBLIC: Tcl_Obj *, DBT *, DBT*, DBTYPE, u_int32_t)); 338 */ 339int 340_SetMultiList(interp, list, key, data, type, flag) 341 Tcl_Interp *interp; 342 Tcl_Obj *list; 343 DBT *key, *data; 344 DBTYPE type; 345 u_int32_t flag; 346{ 347 db_recno_t recno; 348 u_int32_t dlen, klen; 349 int result; 350 void *pointer, *dp, *kp; 351 352 recno = 0; 353 dlen = 0; 354 kp = NULL; 355 356 DB_MULTIPLE_INIT(pointer, data); 357 result = TCL_OK; 358 359 if (type == DB_RECNO || type == DB_QUEUE) 360 recno = *(db_recno_t *) key->data; 361 else 362 kp = key->data; 363 klen = key->size; 364 do { 365 if (flag & DB_MULTIPLE_KEY) { 366 if (type == DB_RECNO || type == DB_QUEUE) 367 DB_MULTIPLE_RECNO_NEXT(pointer, 368 data, recno, dp, dlen); 369 else 370 DB_MULTIPLE_KEY_NEXT(pointer, 371 data, kp, klen, dp, dlen); 372 } else 373 DB_MULTIPLE_NEXT(pointer, data, dp, dlen); 374 375 if (pointer == NULL) 376 break; 377 378 if (type == DB_RECNO || type == DB_QUEUE) { 379 result = 380 _SetListRecnoElem(interp, list, recno, dp, dlen); 381 recno++; 382 /* Wrap around and skip zero. */ 383 if (recno == 0) 384 recno++; 385 } else 386 result = _SetListElem(interp, list, kp, klen, dp, dlen); 387 } while (result == TCL_OK); 388 389 return (result); 390} 391/* 392 * PUBLIC: int _GetGlobPrefix __P((char *, char **)); 393 */ 394int 395_GetGlobPrefix(pattern, prefix) 396 char *pattern; 397 char **prefix; 398{ 399 int i, j; 400 char *p; 401 402 /* 403 * Duplicate it, we get enough space and most of the work is done. 404 */ 405 if (__os_strdup(NULL, pattern, prefix) != 0) 406 return (1); 407 408 p = *prefix; 409 for (i = 0, j = 0; p[i] && !GLOB_CHAR(p[i]); i++, j++) 410 /* 411 * Check for an escaped character and adjust 412 */ 413 if (p[i] == '\\' && p[i+1]) { 414 p[j] = p[i+1]; 415 i++; 416 } else 417 p[j] = p[i]; 418 p[j] = 0; 419 return (0); 420} 421 422/* 423 * PUBLIC: int _ReturnSetup __P((Tcl_Interp *, int, int, char *)); 424 */ 425int 426_ReturnSetup(interp, ret, ok, errmsg) 427 Tcl_Interp *interp; 428 int ret, ok; 429 char *errmsg; 430{ 431 char *msg; 432 433 if (ret > 0) 434 return (_ErrorSetup(interp, ret, errmsg)); 435 436 /* 437 * We either have success or a DB error. If a DB error, set up the 438 * string. We return an error if not one of the errors we catch. 439 * If anyone wants to reset the result to return anything different, 440 * then the calling function is responsible for doing so via 441 * Tcl_ResetResult or another Tcl_SetObjResult. 442 */ 443 if (ret == 0) { 444 Tcl_SetResult(interp, "0", TCL_STATIC); 445 return (TCL_OK); 446 } 447 448 msg = db_strerror(ret); 449 Tcl_AppendResult(interp, msg, NULL); 450 451 if (ok) 452 return (TCL_OK); 453 else { 454 Tcl_SetErrorCode(interp, "BerkeleyDB", msg, NULL); 455 return (TCL_ERROR); 456 } 457} 458 459/* 460 * PUBLIC: int _ErrorSetup __P((Tcl_Interp *, int, char *)); 461 */ 462int 463_ErrorSetup(interp, ret, errmsg) 464 Tcl_Interp *interp; 465 int ret; 466 char *errmsg; 467{ 468 Tcl_SetErrno(ret); 469 Tcl_AppendResult(interp, errmsg, ":", Tcl_PosixError(interp), NULL); 470 return (TCL_ERROR); 471} 472 473/* 474 * PUBLIC: void _ErrorFunc __P((const DB_ENV *, CONST char *, const char *)); 475 */ 476void 477_ErrorFunc(dbenv, pfx, msg) 478 const DB_ENV *dbenv; 479 CONST char *pfx; 480 const char *msg; 481{ 482 DBTCL_INFO *p; 483 Tcl_Interp *interp; 484 size_t size; 485 char *err; 486 487 COMPQUIET(dbenv, NULL); 488 489 p = _NameToInfo(pfx); 490 if (p == NULL) 491 return; 492 interp = p->i_interp; 493 494 size = strlen(pfx) + strlen(msg) + 4; 495 /* 496 * If we cannot allocate enough to put together the prefix 497 * and message then give them just the message. 498 */ 499 if (__os_malloc(NULL, size, &err) != 0) { 500 Tcl_AddErrorInfo(interp, msg); 501 Tcl_AppendResult(interp, msg, "\n", NULL); 502 return; 503 } 504 snprintf(err, size, "%s: %s", pfx, msg); 505 Tcl_AddErrorInfo(interp, err); 506 Tcl_AppendResult(interp, err, "\n", NULL); 507 __os_free(NULL, err); 508 return; 509} 510 511/* 512 * PUBLIC: void _EventFunc __P((DB_ENV *, u_int32_t, void *)); 513 */ 514void 515_EventFunc(dbenv, event, info) 516 DB_ENV *dbenv; 517 u_int32_t event; 518 void *info; 519{ 520#define TCLDB_EVENTITEMS 2 /* Event name and any info */ 521#define TCLDB_SENDEVENT 3 /* Event Tcl proc, env name, event objects. */ 522 DBTCL_INFO *ip; 523 Tcl_Interp *interp; 524 Tcl_Obj *event_o, *origobj; 525 Tcl_Obj *myobjv[TCLDB_EVENTITEMS], *objv[TCLDB_SENDEVENT]; 526 int i, myobjc, result; 527 528 ip = (DBTCL_INFO *)dbenv->app_private; 529 interp = ip->i_interp; 530 if (ip->i_event == NULL) 531 return; 532 objv[0] = ip->i_event; 533 objv[1] = NewStringObj(ip->i_name, strlen(ip->i_name)); 534 535 /* 536 * Most events don't have additional info. Assume none 537 * and handle individually those that do. 538 */ 539 myobjv[1] = NULL; 540 myobjc = 1; 541 switch (event) { 542 case DB_EVENT_PANIC: 543 /* 544 * Info is the original error code. 545 */ 546 myobjv[0] = NewStringObj("panic", strlen("panic")); 547 myobjv[myobjc++] = Tcl_NewIntObj(*(int *)info); 548 break; 549 case DB_EVENT_REP_CLIENT: 550 myobjv[0] = NewStringObj("rep_client", strlen("rep_client")); 551 break; 552 case DB_EVENT_REP_ELECTED: 553 myobjv[0] = NewStringObj("elected", strlen("elected")); 554 break; 555 case DB_EVENT_REP_MASTER: 556 myobjv[0] = NewStringObj("rep_master", strlen("rep_master")); 557 break; 558 case DB_EVENT_REP_NEWMASTER: 559 /* 560 * Info is the EID of the new master. 561 */ 562 myobjv[0] = NewStringObj("newmaster", strlen("newmaster")); 563 myobjv[myobjc++] = Tcl_NewIntObj(*(int *)info); 564 break; 565 case DB_EVENT_REP_PERM_FAILED: 566 myobjv[0] = NewStringObj("perm_failed", strlen("perm_failed")); 567 break; 568 case DB_EVENT_REP_STARTUPDONE: 569 myobjv[0] = NewStringObj("startupdone", strlen("startupdone")); 570 break; 571 case DB_EVENT_WRITE_FAILED: 572 myobjv[0] = 573 NewStringObj("write_failed", strlen("write_failed")); 574 break; 575 default: 576 __db_errx(dbenv->env, "Tcl unknown event %lu", (u_long)event); 577 return; 578 } 579 580 for (i = 0; i < myobjc; i++) 581 Tcl_IncrRefCount(myobjv[i]); 582 583 event_o = Tcl_NewListObj(myobjc, myobjv); 584 Tcl_IncrRefCount(event_o); 585 objv[2] = event_o; 586 587 /* 588 * We really want to return the original result to the 589 * user. So, save the result obj here, and then after 590 * we've taken care of the Tcl_EvalObjv, set the result 591 * back to this original result. 592 */ 593 origobj = Tcl_GetObjResult(interp); 594 Tcl_IncrRefCount(origobj); 595 result = Tcl_EvalObjv(interp, TCLDB_SENDEVENT, objv, 0); 596 if (result != TCL_OK) { 597 /* 598 * XXX 599 * This probably isn't the right error behavior, but 600 * this error should only happen if the Tcl callback is 601 * somehow invalid, which is a fatal scripting bug. 602 * The event handler is a void function so we either 603 * just return or abort. 604 * For now, abort. 605 */ 606 __db_errx(dbenv->env, "Tcl event failure"); 607 __os_abort(dbenv->env); 608 } 609 610 Tcl_SetObjResult(interp, origobj); 611 Tcl_DecrRefCount(origobj); 612 for (i = 0; i < myobjc; i++) 613 Tcl_DecrRefCount(myobjv[i]); 614 Tcl_DecrRefCount(event_o); 615 616 return; 617} 618 619#define INVALID_LSNMSG "Invalid LSN with %d parts. Should have 2.\n" 620 621/* 622 * PUBLIC: int _GetLsn __P((Tcl_Interp *, Tcl_Obj *, DB_LSN *)); 623 */ 624int 625_GetLsn(interp, obj, lsn) 626 Tcl_Interp *interp; 627 Tcl_Obj *obj; 628 DB_LSN *lsn; 629{ 630 Tcl_Obj **myobjv; 631 char msg[MSG_SIZE]; 632 int myobjc, result; 633 u_int32_t tmp; 634 635 result = Tcl_ListObjGetElements(interp, obj, &myobjc, &myobjv); 636 if (result == TCL_ERROR) 637 return (result); 638 if (myobjc != 2) { 639 result = TCL_ERROR; 640 snprintf(msg, MSG_SIZE, INVALID_LSNMSG, myobjc); 641 Tcl_SetResult(interp, msg, TCL_VOLATILE); 642 return (result); 643 } 644 result = _GetUInt32(interp, myobjv[0], &tmp); 645 if (result == TCL_ERROR) 646 return (result); 647 lsn->file = tmp; 648 result = _GetUInt32(interp, myobjv[1], &tmp); 649 lsn->offset = tmp; 650 return (result); 651} 652 653/* 654 * _GetUInt32 -- 655 * Get a u_int32_t from a Tcl object. Tcl_GetIntFromObj does the 656 * right thing most of the time, but on machines where a long is 8 bytes 657 * and an int is 4 bytes, it errors on integers between the maximum 658 * int32_t and the maximum u_int32_t. This is correct, but we generally 659 * want a u_int32_t in the end anyway, so we use Tcl_GetLongFromObj and do 660 * the bounds checking ourselves. 661 * 662 * This code looks much like Tcl_GetIntFromObj, only with a different 663 * bounds check. It's essentially Tcl_GetUnsignedIntFromObj, which 664 * unfortunately doesn't exist. 665 * 666 * PUBLIC: int _GetUInt32 __P((Tcl_Interp *, Tcl_Obj *, u_int32_t *)); 667 */ 668int 669_GetUInt32(interp, obj, resp) 670 Tcl_Interp *interp; 671 Tcl_Obj *obj; 672 u_int32_t *resp; 673{ 674 int result; 675 long ltmp; 676 677 result = Tcl_GetLongFromObj(interp, obj, <mp); 678 if (result != TCL_OK) 679 return (result); 680 681 if ((unsigned long)ltmp != (u_int32_t)ltmp) { 682 if (interp != NULL) { 683 Tcl_ResetResult(interp); 684 Tcl_AppendToObj(Tcl_GetObjResult(interp), 685 "integer value too large for u_int32_t", -1); 686 } 687 return (TCL_ERROR); 688 } 689 690 *resp = (u_int32_t)ltmp; 691 return (TCL_OK); 692} 693 694/* 695 * _GetFlagsList -- 696 * Get a new Tcl object, containing a list of the string values 697 * associated with a particular set of flag values. 698 * 699 * PUBLIC: Tcl_Obj *_GetFlagsList __P((Tcl_Interp *, u_int32_t, const FN *)); 700 */ 701Tcl_Obj * 702_GetFlagsList(interp, flags, fnp) 703 Tcl_Interp *interp; 704 u_int32_t flags; 705 const FN *fnp; 706{ 707 Tcl_Obj *newlist, *newobj; 708 int result; 709 710 newlist = Tcl_NewObj(); 711 712 /* 713 * If the Berkeley DB library wasn't compiled with statistics, then 714 * we may get a NULL reference. 715 */ 716 if (fnp == NULL) 717 return (newlist); 718 719 /* 720 * Append a Tcl_Obj containing each pertinent flag string to the 721 * specified Tcl list. 722 */ 723 for (; fnp->mask != 0; ++fnp) 724 if (LF_ISSET(fnp->mask)) { 725 newobj = NewStringObj(fnp->name, strlen(fnp->name)); 726 result = 727 Tcl_ListObjAppendElement(interp, newlist, newobj); 728 729 /* 730 * Tcl_ListObjAppendElement is defined to return TCL_OK 731 * unless newlist isn't actually a list (or convertible 732 * into one). If this is the case, we screwed up badly 733 * somehow. 734 */ 735 DB_ASSERT(NULL, result == TCL_OK); 736 } 737 738 return (newlist); 739} 740 741int __debug_stop, __debug_on, __debug_print, __debug_test; 742 743/* 744 * PUBLIC: void _debug_check __P((void)); 745 */ 746void 747_debug_check() 748{ 749 if (__debug_on == 0) 750 return; 751 752 if (__debug_print != 0) { 753 printf("\r%7d:", __debug_on); 754 (void)fflush(stdout); 755 } 756 if (__debug_on++ == __debug_test || __debug_stop) 757 __db_loadme(); 758} 759 760/* 761 * XXX 762 * Tcl 8.1+ Tcl_GetByteArrayFromObj/Tcl_GetIntFromObj bug. 763 * 764 * There is a bug in Tcl 8.1+ and byte arrays in that if it happens 765 * to use an object as both a byte array and something else like 766 * an int, and you've done a Tcl_GetByteArrayFromObj, then you 767 * do a Tcl_GetIntFromObj, your memory is deleted. 768 * 769 * Workaround is for all byte arrays we want to use, if it can be 770 * represented as an integer, we copy it so that we don't lose the 771 * memory. 772 */ 773/* 774 * PUBLIC: int _CopyObjBytes __P((Tcl_Interp *, Tcl_Obj *obj, void *, 775 * PUBLIC: u_int32_t *, int *)); 776 */ 777int 778_CopyObjBytes(interp, obj, newp, sizep, freep) 779 Tcl_Interp *interp; 780 Tcl_Obj *obj; 781 void *newp; 782 u_int32_t *sizep; 783 int *freep; 784{ 785 void *tmp, *new; 786 int i, len, ret; 787 788 /* 789 * If the object is not an int, then just return the byte 790 * array because it won't be transformed out from under us. 791 * If it is a number, we need to copy it. 792 */ 793 *freep = 0; 794 ret = Tcl_GetIntFromObj(interp, obj, &i); 795 tmp = Tcl_GetByteArrayFromObj(obj, &len); 796 *sizep = (u_int32_t)len; 797 if (ret == TCL_ERROR) { 798 Tcl_ResetResult(interp); 799 *(void **)newp = tmp; 800 return (0); 801 } 802 803 /* 804 * If we get here, we have an integer that might be reused 805 * at some other point so we cannot count on GetByteArray 806 * keeping our pointer valid. 807 */ 808 if ((ret = __os_malloc(NULL, (size_t)len, &new)) != 0) 809 return (ret); 810 memcpy(new, tmp, (size_t)len); 811 *(void **)newp = new; 812 *freep = 1; 813 return (0); 814} 815