1/* 2 * qebind.c -- 3 * 4 * This module implements quasi-events. 5 * 6 * Copyright (c) 2002-2009 Tim Baker 7 * 8 * RCS: @(#) $Id: qebind.c,v 1.22 2010/03/08 17:04:58 treectrl Exp $ 9 */ 10 11/* 12 * A general purpose module that allows a program to send event-like 13 * messages to scripts, and to bind Tcl commands to those quasi-events. 14 * Each event has it's own detail field and other fields, and this 15 * module performs %-substitution on bound scripts just like regular 16 * Tk binding model. 17 * 18 * To use it first call QE_BindInit() to initialize the package. 19 * Then call QE_InstallEvent() for each new event you wish to define. 20 * For events with details, call QE_InstallDetail() to register each 21 * detail associated with a specific event type. Then create a 22 * binding table, which records all binding commands defined by your 23 * scripts, with QE_CreateBindingTable(). QE_BindCmd() is 24 * called to associate a Tcl script with a given event for a particular 25 * object. The objects that commands are bound to can be a Tk widget or any 26 * string, just like the usual "bind" command. Bindings on Tk widgets are 27 * automatically deleted when the widget is destroyed. 28 */ 29 30#include <ctype.h> 31#include <string.h> 32#include <tcl.h> 33#include <tk.h> 34#include "qebind.h" 35 36#define dbwin TreeCtrl_dbwin 37MODULE_SCOPE void dbwin(char *fmt, ...); 38 39/* 40 * The macro below is used to modify a "char" value (e.g. by casting 41 * it to an unsigned character) so that it can be used safely with 42 * macros such as isspace. 43 */ 44 45#define UCHAR(c) ((unsigned char) (c)) 46 47int debug_bindings = 0; 48 49/* 50 * Allow bindings to be deactivated. 51 */ 52#define BIND_ACTIVE 1 53 54/* 55 * Allow new events to be added/removed by Tcl commands. 56 */ 57#define ALLOW_INSTALL 1 58 59/* 60 * Delete scripts bound to a window when that window is destroyed. 61 */ 62#define DELETE_WIN_BINDINGS 1 63 64typedef struct BindValue { 65 int type; /* Type of event, etc) */ 66 int detail; /* Misc. other information, or 0 for none */ 67 ClientData object; 68 char *command; 69 int specific; /* For less-specific events (detail=0), this is 1 70 * if a more-specific event (detail>0) exists. */ 71 struct BindValue *nextValue; /* list of BindValues matching event */ 72#if BIND_ACTIVE 73 int active; /* 1 if binding is "active", 0 otherwise */ 74#endif /* BIND_ACTIVE */ 75} BindValue; 76 77typedef struct Pattern { 78 int type; /* Type of event */ 79 int detail; /* Misc. other information, or 0 for none */ 80} Pattern; 81 82typedef struct PatternTableKey { 83 int type; /* Type of event */ 84 int detail; /* Misc. other information, or 0 for none */ 85} PatternTableKey; 86 87typedef struct ObjectTableKey { 88 int type; /* Type of event */ 89 int detail; /* Misc. other information, or 0 for none */ 90 ClientData object; /* Object info */ 91} ObjectTableKey; 92 93typedef struct Detail { 94 Tk_Uid name; /* Name of detail */ 95 int code; /* Detail code */ 96 struct EventInfo *event; /* Associated event */ 97 QE_ExpandProc expandProc; /* Callback to expand % in scripts */ 98#if ALLOW_INSTALL 99 int dynamic; /* Created by QE_InstallCmd() */ 100 char *command; /* Tcl command to expand percents, or NULL */ 101#endif 102 struct Detail *next; /* List of Details for event */ 103} Detail; 104 105typedef struct EventInfo { 106 char *name; /* Name of event */ 107 int type; /* Type of event */ 108 QE_ExpandProc expandProc; /* Callback to expand % in scripts */ 109 Detail *detailList; /* List of Details */ 110 int nextDetailId; /* Next unique Detail.code */ 111#if ALLOW_INSTALL 112 int dynamic; /* Created by QE_InstallCmd() */ 113 char *command; /* Tcl command to expand percents, or NULL */ 114#endif 115 struct EventInfo *next; /* List of all EventInfos */ 116} EventInfo; 117 118typedef struct GenerateField { 119 char which; /* The %-char */ 120 char *string; /* Replace %-char with it */ 121} GenerateField; 122 123typedef struct GenerateData { 124 GenerateField staticField[20]; 125 GenerateField *field; 126 int count; 127 char *command; /* Tcl command to expand percents, or NULL */ 128} GenerateData; 129 130typedef struct BindingTable { 131 Tcl_Interp *interp; 132 Tcl_HashTable patternTable; /* Key: PatternTableKey, Value: (BindValue *) */ 133 Tcl_HashTable objectTable; /* Key: ObjectTableKey, Value: (BindValue *) */ 134 Tcl_HashTable eventTableByName; /* Key: string, Value: EventInfo */ 135 Tcl_HashTable eventTableByType; /* Key: int, Value: EventInfo */ 136 Tcl_HashTable detailTableByType; /* Key: PatternTableKey, Value: Detail */ 137#if DELETE_WIN_BINDINGS 138 Tcl_HashTable winTable; /* Key: Tk_Uid of window name, Value: WinTableValue */ 139#endif 140 EventInfo *eventList; /* List of all EventInfos */ 141 int nextEventId; /* Next unique EventInfo.type */ 142} BindingTable; 143 144static void ExpandPercents(BindingTable *bindPtr, ClientData object, char *command, 145 QE_Event *eventPtr, QE_ExpandProc expandProc, Tcl_DString *result); 146static int ParseEventDescription(BindingTable *bindPtr, char *eventPattern, 147 Pattern *patPtr, EventInfo **eventInfoPtr, Detail **detailPtr); 148static int FindSequence(BindingTable *bindPtr, ClientData object, 149 char *eventString, int create, int *created, BindValue **result); 150static void Percents_CharMap(QE_ExpandArgs *args); 151static void Percents_Command(QE_ExpandArgs *args); 152#if ALLOW_INSTALL 153typedef struct PercentsData { 154 GenerateData *gdPtr; 155 char *command; 156 EventInfo *eventPtr; 157 Detail *detailPtr; 158} PercentsData; 159#endif 160static int DeleteBinding(BindingTable *bindPtr, BindValue *valuePtr); 161static EventInfo *FindEvent(BindingTable *bindPtr, int eventType); 162 163static int initialized = 0; 164 165int QE_BindInit(Tcl_Interp *interp) 166{ 167 if (initialized) 168 return TCL_OK; 169 170 initialized = 1; 171 172 return TCL_OK; 173} 174 175static int CheckName(char *name) 176{ 177 char *p = name; 178 179 if (*p == '\0') 180 return TCL_ERROR; 181 while ((*p != '\0') && (*p != '-') && !isspace(UCHAR(*p))) 182 p++; 183 if (*p == '\0') 184 return TCL_OK; 185 return TCL_ERROR; 186} 187 188int QE_InstallEvent(QE_BindingTable bindingTable, char *name, QE_ExpandProc expandProc) 189{ 190 BindingTable *bindPtr = (BindingTable *) bindingTable; 191 Tcl_HashEntry *hPtr; 192 EventInfo *eiPtr; 193 int isNew; 194 int type; 195 196 if (CheckName(name) != TCL_OK) 197 { 198 Tcl_AppendResult(bindPtr->interp, "bad event name \"", name, "\"", 199 (char *) NULL); 200 return 0; 201 } 202 203 hPtr = Tcl_CreateHashEntry(&bindPtr->eventTableByName, name, &isNew); 204 if (!isNew) 205 { 206 Tcl_AppendResult(bindPtr->interp, "event \"", 207 name, "\" already exists", NULL); 208 return 0; 209 } 210 211 type = bindPtr->nextEventId++; 212 213 eiPtr = (EventInfo *) Tcl_Alloc(sizeof(EventInfo)); 214 eiPtr->name = Tcl_Alloc(strlen(name) + 1); 215 strcpy(eiPtr->name, name); 216 eiPtr->type = type; 217 eiPtr->expandProc = expandProc; 218 eiPtr->detailList = NULL; 219 eiPtr->nextDetailId = 1; 220#ifdef ALLOW_INSTALL 221 eiPtr->dynamic = 0; 222 eiPtr->command = NULL; 223#endif 224 225 Tcl_SetHashValue(hPtr, (ClientData) eiPtr); 226 227 hPtr = Tcl_CreateHashEntry(&bindPtr->eventTableByType, (char *) type, &isNew); 228 Tcl_SetHashValue(hPtr, (ClientData) eiPtr); 229 230 /* List of EventInfos */ 231 eiPtr->next = bindPtr->eventList; 232 bindPtr->eventList = eiPtr; 233 234 return type; 235} 236 237int QE_InstallDetail(QE_BindingTable bindingTable, char *name, int eventType, QE_ExpandProc expandProc) 238{ 239 BindingTable *bindPtr = (BindingTable *) bindingTable; 240 Tcl_HashEntry *hPtr; 241 Detail *dPtr; 242 EventInfo *eiPtr; 243 PatternTableKey key; 244 int isNew; 245 int code; 246 247 if (CheckName(name) != TCL_OK) 248 { 249 Tcl_AppendResult(bindPtr->interp, "bad detail name \"", name, "\"", 250 (char *) NULL); 251 return 0; 252 } 253 254 /* Find the event this detail goes with */ 255 eiPtr = FindEvent(bindPtr, eventType); 256 if (eiPtr == NULL) 257 return 0; 258 259 /* Verify the detail is not already defined for this event */ 260 for (dPtr = eiPtr->detailList; 261 dPtr != NULL; 262 dPtr = dPtr->next) 263 { 264 if (strcmp(dPtr->name, name) == 0) 265 { 266 Tcl_AppendResult(bindPtr->interp, 267 "detail \"", name, "\" already exists for event \"", 268 eiPtr->name, "\"", NULL); 269 return 0; 270 } 271 } 272 273 code = eiPtr->nextDetailId++; 274 275 /* New Detail for detailTable */ 276 dPtr = (Detail *) Tcl_Alloc(sizeof(Detail)); 277 dPtr->name = Tk_GetUid(name); 278 dPtr->code = code; 279 dPtr->event = eiPtr; 280 dPtr->expandProc = expandProc; 281#if ALLOW_INSTALL 282 dPtr->dynamic = 0; 283 dPtr->command = NULL; 284#endif 285 286 /* Entry to find detail by event type and detail code */ 287 key.type = eventType; 288 key.detail = code; 289 hPtr = Tcl_CreateHashEntry(&bindPtr->detailTableByType, (char *) &key, &isNew); 290 Tcl_SetHashValue(hPtr, (ClientData) dPtr); 291 292 /* List of Details */ 293 dPtr->next = eiPtr->detailList; 294 eiPtr->detailList = dPtr; 295 296 return code; 297} 298 299static void DeleteEvent(BindingTable *bindPtr, EventInfo *eiPtr) 300{ 301 EventInfo *eiPrev; 302 Detail *dPtr, *dNext; 303 304 /* Free Details */ 305 for (dPtr = eiPtr->detailList; 306 dPtr != NULL; 307 dPtr = dNext) 308 { 309 dNext = dPtr->next; 310#ifdef ALLOW_INSTALL 311 if (dPtr->command != NULL) 312 Tcl_Free(dPtr->command); 313#endif 314 memset((char *) dPtr, 0xAA, sizeof(Detail)); 315 Tcl_Free((char *) dPtr); 316 } 317 318 if (bindPtr->eventList == eiPtr) 319 bindPtr->eventList = eiPtr->next; 320 else 321 { 322 for (eiPrev = bindPtr->eventList; 323 eiPrev->next != eiPtr; 324 eiPrev = eiPrev->next) 325 { 326 } 327 eiPrev->next = eiPtr->next; 328 } 329 330 /* Free EventInfo */ 331 Tcl_Free(eiPtr->name); 332#ifdef ALLOW_INSTALL 333 if (eiPtr->command != NULL) 334 Tcl_Free(eiPtr->command); 335#endif 336 memset((char *) eiPtr, 0xAA, sizeof(EventInfo)); 337 Tcl_Free((char *) eiPtr); 338} 339 340int QE_UninstallEvent(QE_BindingTable bindingTable, int eventType) 341{ 342 BindingTable *bindPtr = (BindingTable *) bindingTable; 343 Tcl_HashEntry *hPtr; 344 Tcl_HashSearch search; 345 EventInfo *eiPtr; 346 BindValue *valuePtr, **valueList; 347 Tcl_DString dString; 348 int i, count = 0; 349 350 /* Find the event */ 351 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByType, (char *) eventType); 352 if (hPtr == NULL) 353 return TCL_ERROR; 354 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 355 Tcl_DeleteHashEntry(hPtr); 356 357 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eiPtr->name); 358 Tcl_DeleteHashEntry(hPtr); 359 360 Tcl_DStringInit(&dString); 361 362 /* Find all bindings to this event for any object */ 363 hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); 364 while (hPtr != NULL) 365 { 366 valuePtr = (BindValue *) Tcl_GetHashValue(hPtr); 367 while (valuePtr != NULL) 368 { 369 if (valuePtr->type == eiPtr->type) 370 { 371 Tcl_DStringAppend(&dString, (char *) &valuePtr, sizeof(valuePtr)); 372 count++; 373 } 374 valuePtr = valuePtr->nextValue; 375 } 376 hPtr = Tcl_NextHashEntry(&search); 377 } 378 379 valueList = (BindValue **) Tcl_DStringValue(&dString); 380 for (i = 0; i < count; i++) 381 DeleteBinding(bindPtr, valueList[i]); 382 383 Tcl_DStringFree(&dString); 384 385 DeleteEvent(bindPtr, eiPtr); 386 387 return TCL_OK; 388} 389 390int QE_UninstallDetail(QE_BindingTable bindingTable, int eventType, int detail) 391{ 392 BindingTable *bindPtr = (BindingTable *) bindingTable; 393 PatternTableKey key; 394 Tcl_HashEntry *hPtr; 395 Detail *dPtr = NULL, *dPrev; 396 EventInfo *eiPtr; 397 398 /* Find the event */ 399 eiPtr = FindEvent(bindPtr, eventType); 400 if (eiPtr == NULL) 401 return TCL_ERROR; 402 403 if (eiPtr->detailList == NULL) 404 return TCL_ERROR; 405 406 /* Delete all bindings on this event/detail for all objects */ 407 while (1) 408 { 409 key.type = eventType; 410 key.detail = detail; 411 hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); 412 if (hPtr == NULL) 413 break; 414 DeleteBinding(bindPtr, (BindValue *) Tcl_GetHashValue(hPtr)); 415 } 416 417 if (eiPtr->detailList->code == detail) 418 { 419 dPtr = eiPtr->detailList; 420 eiPtr->detailList = eiPtr->detailList->next; 421 } 422 else 423 { 424 for (dPrev = eiPtr->detailList; 425 dPrev != NULL; 426 dPrev = dPrev->next) 427 { 428 if ((dPrev->next != NULL) && (dPrev->next->code == detail)) 429 { 430 dPtr = dPrev->next; 431 dPrev->next = dPtr->next; 432 break; 433 } 434 } 435 if (dPtr == NULL) 436 return TCL_ERROR; 437 } 438 439#ifdef ALLOW_INSTALL 440 if (dPtr->command != NULL) 441 Tcl_Free(dPtr->command); 442#endif 443 memset((char *) dPtr, 0xAA, sizeof(Detail)); 444 Tcl_Free((char *) dPtr); 445 446 key.type = eventType; 447 key.detail = detail; 448 hPtr = Tcl_FindHashEntry(&bindPtr->detailTableByType, (char *) &key); 449 Tcl_DeleteHashEntry(hPtr); 450 451 return TCL_OK; 452} 453 454static EventInfo *FindEvent(BindingTable *bindPtr, int eventType) 455{ 456 Tcl_HashEntry *hPtr; 457 458 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByType, (char *) eventType); 459 if (hPtr == NULL) return NULL; 460 return (EventInfo *) Tcl_GetHashValue(hPtr); 461} 462 463static Detail *FindDetail(BindingTable *bindPtr, int eventType, int code) 464{ 465 PatternTableKey key; 466 Tcl_HashEntry *hPtr; 467 468 key.type = eventType; 469 key.detail = code; 470 hPtr = Tcl_FindHashEntry(&bindPtr->detailTableByType, (char *) &key); 471 if (hPtr == NULL) return NULL; 472 return (Detail *) Tcl_GetHashValue(hPtr); 473} 474 475#if DELETE_WIN_BINDINGS 476typedef struct WinTableValue 477{ 478 BindingTable *bindPtr; 479 ClientData object; 480 Tk_Window tkwin; 481 int count; /* Number of BindValues on object */ 482} WinTableValue; 483static void TkWinEventProc(ClientData clientData, XEvent *eventPtr) 484{ 485 WinTableValue *cd = (WinTableValue *) clientData; 486 BindingTable *bindPtr = cd->bindPtr; 487 ClientData object = cd->object; 488 489 if (eventPtr->type != DestroyNotify) 490 return; 491 492 QE_DeleteBinding((QE_BindingTable) bindPtr, object, NULL); 493} 494#endif 495 496QE_BindingTable QE_CreateBindingTable(Tcl_Interp *interp) 497{ 498 BindingTable *bindPtr; 499 500 bindPtr = (BindingTable *) Tcl_Alloc(sizeof(BindingTable)); 501 bindPtr->interp = interp; 502 Tcl_InitHashTable(&bindPtr->patternTable, 503 sizeof(PatternTableKey) / sizeof(int)); 504 Tcl_InitHashTable(&bindPtr->objectTable, 505 sizeof(ObjectTableKey) / sizeof(int)); 506 Tcl_InitHashTable(&bindPtr->eventTableByName, TCL_STRING_KEYS); 507 Tcl_InitHashTable(&bindPtr->eventTableByType, TCL_ONE_WORD_KEYS); 508 Tcl_InitHashTable(&bindPtr->detailTableByType, 509 sizeof(PatternTableKey) / sizeof(int)); 510#if DELETE_WIN_BINDINGS 511 Tcl_InitHashTable(&bindPtr->winTable, TCL_ONE_WORD_KEYS); 512#endif 513 bindPtr->nextEventId = 1; 514 bindPtr->eventList = NULL; 515 516 return (QE_BindingTable) bindPtr; 517} 518 519void QE_DeleteBindingTable(QE_BindingTable bindingTable) 520{ 521 BindingTable *bindPtr = (BindingTable *) bindingTable; 522 Tcl_HashEntry *hPtr; 523 Tcl_HashSearch search; 524 EventInfo *eiPtr, *eiNext; 525 Detail *dPtr, *dNext; 526 527 hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); 528 while (hPtr != NULL) 529 { 530 BindValue *valuePtr = (BindValue *) Tcl_GetHashValue(hPtr); 531 while (valuePtr != NULL) 532 { 533 BindValue *nextValue = valuePtr->nextValue; 534 Tcl_Free((char *) valuePtr->command); 535 memset((char *) valuePtr, 0xAA, sizeof(BindValue)); 536 Tcl_Free((char *) valuePtr); 537 valuePtr = nextValue; 538 } 539 hPtr = Tcl_NextHashEntry(&search); 540 } 541 Tcl_DeleteHashTable(&bindPtr->patternTable); 542 Tcl_DeleteHashTable(&bindPtr->objectTable); 543 544 for (eiPtr = bindPtr->eventList; 545 eiPtr != NULL; 546 eiPtr = eiNext) 547 { 548 eiNext = eiPtr->next; 549 550 /* Free Detail */ 551 for (dPtr = eiPtr->detailList; 552 dPtr != NULL; 553 dPtr = dNext) 554 { 555 dNext = dPtr->next; 556#ifdef ALLOW_INSTALL 557 if (dPtr->command != NULL) 558 Tcl_Free(dPtr->command); 559#endif 560 memset((char *) dPtr, 0xAA, sizeof(Detail)); 561 Tcl_Free((char *) dPtr); 562 } 563 564 /* Free EventInfo */ 565 Tcl_Free(eiPtr->name); 566#ifdef ALLOW_INSTALL 567 if (eiPtr->command != NULL) 568 Tcl_Free(eiPtr->command); 569#endif 570 memset((char *) eiPtr, 0xAA, sizeof(EventInfo)); 571 Tcl_Free((char *) eiPtr); 572 } 573 574 Tcl_DeleteHashTable(&bindPtr->eventTableByName); 575 Tcl_DeleteHashTable(&bindPtr->eventTableByType); 576 Tcl_DeleteHashTable(&bindPtr->detailTableByType); 577 578#if DELETE_WIN_BINDINGS 579 hPtr = Tcl_FirstHashEntry(&bindPtr->winTable, &search); 580 while (hPtr != NULL) 581 { 582 WinTableValue *cd = (WinTableValue *) Tcl_GetHashValue(hPtr); 583 584 Tk_DeleteEventHandler(cd->tkwin, StructureNotifyMask, 585 TkWinEventProc, (ClientData) cd); 586 Tcl_Free((char *) cd); 587 hPtr = Tcl_NextHashEntry(&search); 588 } 589 Tcl_DeleteHashTable(&bindPtr->winTable); 590#endif 591 592 memset((char *) bindPtr, 0xAA, sizeof(BindingTable)); 593 Tcl_Free((char *) bindPtr); 594} 595 596int QE_CreateBinding(QE_BindingTable bindingTable, ClientData object, 597 char *eventString, char *command, int append) 598{ 599 BindingTable *bindPtr = (BindingTable *) bindingTable; 600 BindValue *valuePtr; 601 int isNew, length; 602 char *cmdOld, *cmdNew; 603 604 if (FindSequence(bindPtr, object, eventString, 1, &isNew, &valuePtr) != TCL_OK) 605 return TCL_ERROR; 606 607 /* created a new objectTable entry */ 608 if (isNew) 609 { 610 Tcl_HashEntry *hPtr; 611 PatternTableKey key; 612#if DELETE_WIN_BINDINGS 613 char *winName = (char *) object; 614 615 if (winName[0] == '.') 616 { 617 Tk_Window tkwin = Tk_MainWindow(bindPtr->interp); 618 Tk_Window tkwin2; 619 620 tkwin2 = Tk_NameToWindow(bindPtr->interp, winName, tkwin); 621 if (tkwin2 != NULL) 622 { 623 WinTableValue *cd; 624 625 hPtr = Tcl_CreateHashEntry(&bindPtr->winTable, object, &isNew); 626 if (isNew) 627 { 628 cd = (WinTableValue *) Tcl_Alloc(sizeof(WinTableValue)); 629 cd->bindPtr = bindPtr; 630 cd->object = object; 631 cd->tkwin = tkwin2; 632 cd->count = 0; 633 Tk_CreateEventHandler(tkwin2, StructureNotifyMask, 634 TkWinEventProc, (ClientData) cd); 635 Tcl_SetHashValue(hPtr, (ClientData) cd); 636 } 637 else 638 { 639 cd = (WinTableValue *) Tcl_GetHashValue(hPtr); 640 } 641 /* Number of BindValues for this window */ 642 cd->count++; 643 } 644 } 645#endif 646 647 key.type = valuePtr->type; 648 key.detail = valuePtr->detail; 649 hPtr = Tcl_CreateHashEntry(&bindPtr->patternTable, (char *) &key, 650 &isNew); 651 652 /* 653 * A patternTable entry exists for each different type/detail. 654 * The entry points to a BindValue which is the head of the list 655 * of BindValue's with this same type/detail, but for different 656 * objects. 657 */ 658 if (!isNew) 659 { 660 valuePtr->nextValue = (BindValue *) Tcl_GetHashValue(hPtr); 661 } 662 Tcl_SetHashValue(hPtr, (ClientData) valuePtr); 663 } 664 665 cmdOld = valuePtr->command; 666 667 /* Append given command to any existing command */ 668 if (append && cmdOld) 669 { 670 length = strlen(cmdOld) + strlen(command) + 2; 671 cmdNew = Tcl_Alloc((unsigned) length); 672 (void) sprintf(cmdNew, "%s\n%s", cmdOld, command); 673 } 674 /* Copy the given command */ 675 else 676 { 677 cmdNew = (char *) Tcl_Alloc((unsigned) strlen(command) + 1); 678 (void) strcpy(cmdNew, command); 679 } 680 681 /* Free the old command, if any */ 682 if (cmdOld) Tcl_Free(cmdOld); 683 684 /* Save command associated with this binding */ 685 valuePtr->command = cmdNew; 686 687 return TCL_OK; 688} 689 690int QE_DeleteBinding(QE_BindingTable bindingTable, ClientData object, 691 char *eventString) 692{ 693 BindingTable *bindPtr = (BindingTable *) bindingTable; 694 BindValue *valuePtr, **valueList; 695 696 /* Delete all bindings on this object */ 697 if (eventString == NULL) 698 { 699 Tcl_HashEntry *hPtr; 700 Tcl_HashSearch search; 701 Tcl_DString dString; 702 int i, count = 0; 703 704 Tcl_DStringInit(&dString); 705 706 hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); 707 while (hPtr != NULL) 708 { 709 valuePtr = (BindValue *) Tcl_GetHashValue(hPtr); 710 while (valuePtr != NULL) 711 { 712 if (valuePtr->object == object) 713 { 714 Tcl_DStringAppend(&dString, (char *) &valuePtr, 715 sizeof(valuePtr)); 716 count++; 717 break; 718 } 719 valuePtr = valuePtr->nextValue; 720 } 721 hPtr = Tcl_NextHashEntry(&search); 722 } 723 724 valueList = (BindValue **) Tcl_DStringValue(&dString); 725 for (i = 0; i < count; i++) 726 DeleteBinding(bindPtr, valueList[i]); 727 728 Tcl_DStringFree(&dString); 729 730 return TCL_OK; 731 } 732 733 if (FindSequence(bindPtr, object, eventString, 0, NULL, &valuePtr) != TCL_OK) 734 return TCL_ERROR; 735 if (valuePtr == NULL) 736 { 737 Tcl_ResetResult(bindPtr->interp); 738 return TCL_OK; 739 } 740 DeleteBinding(bindPtr, valuePtr); 741 return TCL_OK; 742} 743 744static int DeleteBinding(BindingTable *bindPtr, BindValue *valuePtr) 745{ 746 Tcl_HashEntry *hPtr; 747 BindValue *listPtr; 748 ObjectTableKey keyObj; 749 PatternTableKey keyPat; 750 751 /* Delete the objectTable entry */ 752 keyObj.type = valuePtr->type; 753 keyObj.detail = valuePtr->detail; 754 keyObj.object = valuePtr->object; 755 hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) &keyObj); 756 if (hPtr == NULL) return TCL_ERROR; /* fatal error */ 757 Tcl_DeleteHashEntry(hPtr); 758 759 /* Find the patternTable entry for this type/detail */ 760 keyPat.type = valuePtr->type; 761 keyPat.detail = valuePtr->detail; 762 hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &keyPat); 763 if (hPtr == NULL) return TCL_ERROR; /* fatal error */ 764 765 /* 766 * Get the patternTable value. This is the head of a list of 767 * BindValue's that match the type/detail, but for different 768 * objects; 769 */ 770 listPtr = (BindValue *) Tcl_GetHashValue(hPtr); 771 772 /* The deleted BindValue is the first */ 773 if (listPtr == valuePtr) 774 { 775 /* The deleted BindValue was the only one in the list */ 776 if (valuePtr->nextValue == NULL) 777 { 778 if (debug_bindings) 779 dbwin("QE_DeleteBinding: Deleted pattern type=%d detail=%d\n", 780 valuePtr->type, valuePtr->detail); 781 782 Tcl_DeleteHashEntry(hPtr); 783 } 784 /* The next BindValue is the new head of the list */ 785 else 786 { 787 Tcl_SetHashValue(hPtr, valuePtr->nextValue); 788 } 789 } 790 /* Look for the deleted BindValue in the list, and remove it */ 791 else 792 { 793 while (1) 794 { 795 if (listPtr->nextValue == NULL) return TCL_ERROR; /* fatal */ 796 if (listPtr->nextValue == valuePtr) 797 { 798 if (debug_bindings) 799 dbwin("QE_DeleteBinding: Unlinked binding type=%d detail=%d\n", 800 valuePtr->type, valuePtr->detail); 801 802 listPtr->nextValue = valuePtr->nextValue; 803 break; 804 } 805 listPtr = listPtr->nextValue; 806 } 807 } 808 809#if DELETE_WIN_BINDINGS 810 { 811 char *winName = (char *) valuePtr->object; 812 813 if (winName[0] == '.') 814 { 815 WinTableValue *cd; 816 817 hPtr = Tcl_FindHashEntry(&bindPtr->winTable, winName); 818 if (hPtr == NULL) return TCL_ERROR; /* fatal error */ 819 cd = (WinTableValue *) Tcl_GetHashValue(hPtr); 820 cd->count--; 821 if (cd->count == 0) 822 { 823 Tk_DeleteEventHandler(cd->tkwin, StructureNotifyMask, 824 TkWinEventProc, (ClientData) cd); 825 Tcl_Free((char *) cd); 826 Tcl_DeleteHashEntry(hPtr); 827 } 828 } 829 } 830#endif 831 832 Tcl_Free((char *) valuePtr->command); 833 memset((char *) valuePtr, 0xAA, sizeof(BindValue)); 834 Tcl_Free((char *) valuePtr); 835 836 return TCL_OK; 837} 838 839int QE_GetAllObjects(QE_BindingTable bindingTable) 840{ 841 BindingTable *bindPtr = (BindingTable *) bindingTable; 842 Tcl_HashEntry *hPtr; 843 Tcl_HashSearch search; 844 Tcl_DString dString; 845 ClientData *objectList; 846 int i, count = 0; 847 Tcl_Obj *listObj; 848 849 Tcl_DStringInit(&dString); 850 hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); 851 while (hPtr != NULL) 852 { 853 BindValue *valuePtr = (BindValue *) Tcl_GetHashValue(hPtr); 854 while (valuePtr != NULL) 855 { 856 objectList = (ClientData *) Tcl_DStringValue(&dString); 857 for (i = 0; i < count; i++) 858 { 859 if (objectList[i] == valuePtr->object) 860 break; 861 } 862 if (i >= count) 863 { 864 Tcl_DStringAppend(&dString, (char *) &valuePtr->object, 865 sizeof(ClientData)); 866 count++; 867 } 868 valuePtr = valuePtr->nextValue; 869 } 870 hPtr = Tcl_NextHashEntry(&search); 871 } 872 if (count > 0) 873 { 874 listObj = Tcl_NewListObj(0, NULL); 875 objectList = (ClientData *) Tcl_DStringValue(&dString); 876 for (i = 0; i < count; i++) 877 { 878 Tcl_ListObjAppendElement(bindPtr->interp, listObj, 879 Tcl_NewStringObj((char *) objectList[i], -1)); 880 } 881 Tcl_SetObjResult(bindPtr->interp, listObj); 882 } 883 Tcl_DStringFree(&dString); 884 885 return TCL_OK; 886} 887 888int QE_GetBinding(QE_BindingTable bindingTable, ClientData object, 889 char *eventString) 890{ 891 BindingTable *bindPtr = (BindingTable *) bindingTable; 892 BindValue *valuePtr; 893 894 if (FindSequence(bindPtr, object, eventString, 0, NULL, &valuePtr) != TCL_OK) 895 return TCL_ERROR; 896 if (valuePtr == NULL) 897 return TCL_OK; 898 Tcl_SetObjResult(bindPtr->interp, Tcl_NewStringObj(valuePtr->command, -1)); 899 return TCL_OK; 900} 901 902static void GetPatternString(BindingTable *bindPtr, BindValue *bindValue, Tcl_DString *dString) 903{ 904 EventInfo *eiPtr; 905 906 eiPtr = FindEvent(bindPtr, bindValue->type); 907 if (eiPtr != NULL) 908 { 909 Tcl_DStringAppend(dString, "<", 1); 910 Tcl_DStringAppend(dString, eiPtr->name, -1); 911 if (bindValue->detail) 912 { 913 Detail *detail = FindDetail(bindPtr, bindValue->type, bindValue->detail); 914 if (detail != NULL) 915 { 916 Tcl_DStringAppend(dString, "-", 1); 917 Tcl_DStringAppend(dString, detail->name, -1); 918 } 919 } 920 Tcl_DStringAppend(dString, ">", 1); 921 } 922} 923 924int QE_GetAllBindings(QE_BindingTable bindingTable, ClientData object) 925{ 926 BindingTable *bindPtr = (BindingTable *) bindingTable; 927 Tcl_HashEntry *hPtr; 928 Tcl_HashSearch search; 929 Tcl_DString dString; 930 931 Tcl_DStringInit(&dString); 932 hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); 933 while (hPtr != NULL) 934 { 935 BindValue *valuePtr = (BindValue *) Tcl_GetHashValue(hPtr); 936 while (valuePtr != NULL) 937 { 938 if (valuePtr->object == object) 939 { 940 Tcl_DStringSetLength(&dString, 0); 941 GetPatternString(bindPtr, valuePtr, &dString); 942 Tcl_AppendElement(bindPtr->interp, Tcl_DStringValue(&dString)); 943 break; 944 } 945 valuePtr = valuePtr->nextValue; 946 } 947 hPtr = Tcl_NextHashEntry(&search); 948 } 949 Tcl_DStringFree(&dString); 950 951 return TCL_OK; 952} 953 954int QE_GetEventNames(QE_BindingTable bindingTable) 955{ 956 BindingTable *bindPtr = (BindingTable *) bindingTable; 957 EventInfo *eiPtr; 958 959 for (eiPtr = bindPtr->eventList; 960 eiPtr != NULL; 961 eiPtr = eiPtr->next) 962 { 963 Tcl_AppendElement(bindPtr->interp, eiPtr->name); 964 } 965 966 return TCL_OK; 967} 968 969int QE_GetDetailNames(QE_BindingTable bindingTable, char *eventName) 970{ 971 BindingTable *bindPtr = (BindingTable *) bindingTable; 972 Tcl_HashEntry *hPtr; 973 EventInfo *eiPtr; 974 Detail *dPtr; 975 976 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 977 if (hPtr == NULL) 978 { 979 Tcl_AppendResult(bindPtr->interp, "unknown event \"", eventName, 980 "\"", NULL); 981 return TCL_ERROR; 982 } 983 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 984 985 for (dPtr = eiPtr->detailList; 986 dPtr != NULL; 987 dPtr = dPtr->next) 988 { 989 Tcl_AppendElement(bindPtr->interp, dPtr->name); 990 } 991 992 return TCL_OK; 993} 994 995static void ExpandPercents(BindingTable *bindPtr, ClientData object, 996 char *command, QE_Event *eventPtr, QE_ExpandProc expandProc, 997 Tcl_DString *result) 998{ 999 char *string; 1000 QE_ExpandArgs expandArgs; 1001 1002#if 0 1003 Tcl_DStringSetLength(result, 0); 1004 if (debug_bindings) 1005 dbwin("ExpandPercents on '%s' name=%s type=%d detail=%d expand=%lu\n", 1006 object, eiPtr->name, eiPtr->type, eventPtr->detail, eiPtr->expand); 1007#endif 1008 expandArgs.bindingTable = (QE_BindingTable) bindPtr; 1009 expandArgs.object = object; 1010 expandArgs.event = eventPtr->type; 1011 expandArgs.detail = eventPtr->detail; 1012 expandArgs.result = result; 1013 expandArgs.clientData = eventPtr->clientData; 1014 1015 while (1) 1016 { 1017 for (string = command; (*string != 0) && (*string != '%'); string++) 1018 { 1019 /* Empty loop body. */ 1020 } 1021 if (string != command) 1022 { 1023 Tcl_DStringAppend(result, command, string - command); 1024 command = string; 1025 } 1026 if (*command == 0) 1027 { 1028 break; 1029 } 1030 1031 /* Expand % here */ 1032 expandArgs.which = command[1]; 1033 (*expandProc)(&expandArgs); 1034 1035 command += 2; 1036 } 1037} 1038 1039static void BindEvent(BindingTable *bindPtr, QE_Event *eventPtr, int wantDetail, 1040 EventInfo *eiPtr, Detail *dPtr, GenerateData *gdPtr) 1041{ 1042 Tcl_HashEntry *hPtr; 1043 BindValue *valuePtr; 1044 ObjectTableKey keyObj; 1045 PatternTableKey key; 1046 Tcl_DString scripts, savedResult; 1047 int code; 1048 char *p, *end; 1049 char *command = gdPtr ? gdPtr->command : NULL; 1050 1051 /* Find the first BindValue for this event */ 1052 key.type = eventPtr->type; 1053 key.detail = wantDetail ? eventPtr->detail : 0; 1054 hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); 1055 if (hPtr == NULL) 1056 return; 1057 1058 /* Collect all scripts, with % expanded, separated by null characters. 1059 * Do it this way because anything could happen while evaluating, including 1060 * uninstalling events/details, even the interpreter being deleted. */ 1061 Tcl_DStringInit(&scripts); 1062 1063 for (valuePtr = (BindValue *) Tcl_GetHashValue(hPtr); 1064 valuePtr; valuePtr = valuePtr->nextValue) 1065 { 1066 if (wantDetail && valuePtr->detail) 1067 { 1068 keyObj.type = key.type; 1069 keyObj.detail = 0; 1070 keyObj.object = valuePtr->object; 1071 hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) &keyObj); 1072 if (hPtr != NULL) 1073 { 1074 BindValue *value2Ptr; 1075 value2Ptr = (BindValue *) Tcl_GetHashValue(hPtr); 1076 value2Ptr->specific = 1; 1077 } 1078 } 1079 1080 /* 1081 * If a binding for a more-specific event exists for this object 1082 * and event-type, and this is a binding for a less-specific 1083 * event, then skip this binding, since the binding for the 1084 * more-specific event was already invoked. 1085 */ 1086 else if (!wantDetail && valuePtr->specific) 1087 { 1088 if (debug_bindings) 1089 dbwin("QE_BindEvent: Skipping less-specific event type=%d object='%s'\n", 1090 valuePtr->type, (char *) valuePtr->object); 1091 1092 valuePtr->specific = 0; 1093 continue; 1094 } 1095 1096#if BIND_ACTIVE 1097 /* This binding isn't active */ 1098 if (valuePtr->active == 0) 1099 continue; 1100#endif /* BIND_ACTIVE */ 1101 1102#if ALLOW_INSTALL 1103 if (command == NULL) 1104 { 1105 if ((dPtr != NULL) && (dPtr->command != NULL)) 1106 { 1107 command = dPtr->command; 1108 } 1109 else if (((dPtr == NULL) || 1110 ((dPtr != NULL) && (dPtr->expandProc == NULL))) && 1111 (eiPtr->command != NULL)) 1112 { 1113 command = eiPtr->command; 1114 } 1115 } 1116#endif /* ALLOW_INSTALL */ 1117 1118 /* called by QE_GenerateCmd */ 1119 if (command != NULL) 1120 { 1121 PercentsData data; 1122 1123 data.gdPtr = gdPtr; 1124 data.command = command; 1125 data.eventPtr = eiPtr; 1126 data.detailPtr = dPtr; 1127 eventPtr->clientData = (ClientData) &data; 1128 ExpandPercents(bindPtr, valuePtr->object, valuePtr->command, 1129 eventPtr, Percents_Command, &scripts); 1130 } 1131 1132 /* called by QE_GenerateCmd */ 1133 else if (gdPtr != NULL) 1134 { 1135 /* Called QE_GenerateCmd with: 1136 * a) a static event and no percentsCommand argument, or 1137 * b) a dynamic event with no percentsCommand installed and 1138 * no percentsCommand argument 1139 */ 1140 eventPtr->clientData = (ClientData) gdPtr; 1141 ExpandPercents(bindPtr, valuePtr->object, valuePtr->command, 1142 eventPtr, Percents_CharMap, &scripts); 1143 } 1144 else 1145 { 1146 QE_ExpandProc expandProc = 1147 ((dPtr != NULL) && (dPtr->expandProc != NULL)) ? 1148 dPtr->expandProc : eiPtr->expandProc; 1149 1150 ExpandPercents(bindPtr, valuePtr->object, valuePtr->command, 1151 eventPtr, expandProc, &scripts); 1152 } 1153 1154 /* Separate each script by '\0' */ 1155 Tcl_DStringAppend(&scripts, "", 1); 1156 1157 Tcl_DStringAppend(&scripts, eiPtr->name, -1); 1158 Tcl_DStringAppend(&scripts, "", 1); 1159 1160 Tcl_DStringAppend(&scripts, (valuePtr->detail && dPtr) ? dPtr->name : "", -1); 1161 Tcl_DStringAppend(&scripts, "", 1); 1162 1163 Tcl_DStringAppend(&scripts, valuePtr->object, -1); 1164 Tcl_DStringAppend(&scripts, "", 1); 1165 } 1166 1167 /* Nothing to do. No need to call Tcl_DStringFree(&scripts) */ 1168 if (Tcl_DStringLength(&scripts) == 0) 1169 return; 1170 1171 /* 1172 * As in Tk bindings, we expect that bindings may be invoked 1173 * in the middle of Tcl commands. So we preserve the current 1174 * interpreter result and restore it later. 1175 */ 1176 Tcl_DStringInit(&savedResult); 1177 Tcl_DStringGetResult(bindPtr->interp, &savedResult); 1178 1179 p = Tcl_DStringValue(&scripts); 1180 end = p + Tcl_DStringLength(&scripts); 1181 1182 while (p < end) 1183 { 1184 code = Tcl_GlobalEval(bindPtr->interp, p); 1185 p += strlen(p); 1186 p++; 1187 1188 if (code != TCL_OK) 1189 { 1190 if (code == TCL_CONTINUE) 1191 { 1192 /* Nothing */ 1193 } 1194 else if (code == TCL_BREAK) 1195 { 1196 /* Nothing */ 1197 } 1198 else 1199 { 1200 char buf[256]; 1201 char *eventName = p; 1202 char *detailName = p + strlen(p) + 1; 1203 char *object = detailName + strlen(detailName) + 1; 1204 1205 (void) sprintf(buf, "\n (<%s%s%s> binding on %s)", 1206 eventName, detailName[0] ? "-" : "", detailName, object); 1207 Tcl_AddErrorInfo(bindPtr->interp, buf); 1208 Tcl_BackgroundError(bindPtr->interp); 1209 } 1210 } 1211 1212 /* Skip event\0detail\0object\0 */ 1213 p += strlen(p); 1214 p++; 1215 p += strlen(p); 1216 p++; 1217 p += strlen(p); 1218 p++; 1219 } 1220 1221 Tcl_DStringFree(&scripts); 1222 1223 /* Restore the interpreter result */ 1224 Tcl_DStringResult(bindPtr->interp, &savedResult); 1225} 1226 1227static int BindEventWrapper(QE_BindingTable bindingTable, QE_Event *eventPtr, GenerateData *gdPtr) 1228{ 1229 BindingTable *bindPtr = (BindingTable *) bindingTable; 1230 Detail *dPtr = NULL; 1231 EventInfo *eiPtr; 1232 1233 /* Find the event */ 1234 eiPtr = FindEvent(bindPtr, eventPtr->type); 1235 if (eiPtr == NULL) 1236 return TCL_OK; 1237 1238 /* Find the detail */ 1239 if (eventPtr->detail) 1240 { 1241 dPtr = FindDetail(bindPtr, eventPtr->type, eventPtr->detail); 1242 if (dPtr == NULL) 1243 return TCL_OK; 1244 } 1245 1246 BindEvent(bindPtr, eventPtr, 1, eiPtr, dPtr, gdPtr); 1247 if (eventPtr->detail) 1248 BindEvent(bindPtr, eventPtr, 0, eiPtr, dPtr, gdPtr); 1249 1250 return TCL_OK; 1251} 1252 1253int QE_BindEvent(QE_BindingTable bindingTable, QE_Event *eventPtr) 1254{ 1255 return BindEventWrapper(bindingTable, eventPtr, NULL); 1256} 1257 1258static char *GetField(char *p, char *copy, int size) 1259{ 1260 int ch = *p; 1261 1262 while ((ch != '\0') && !isspace(UCHAR(ch)) && 1263 ((ch != '>') || (p[1] != '\0')) 1264 && (ch != '-') && (size > 1)) 1265 { 1266 *copy = ch; 1267 p++; 1268 copy++; 1269 size--; 1270 ch = *p; 1271 } 1272 *copy = '\0'; 1273 1274 while ((*p == '-') || isspace(UCHAR(*p))) 1275 { 1276 p++; 1277 } 1278 return p; 1279} 1280 1281#define FIELD_SIZE 48 1282 1283static int ParseEventDescription1(BindingTable *bindPtr, char *pattern, char eventName[FIELD_SIZE], char detailName[FIELD_SIZE]) 1284{ 1285 Tcl_Interp *interp = bindPtr->interp; 1286 char *p = pattern; 1287 1288 eventName[0] = detailName[0] = '\0'; 1289 1290 /* First char must by opening < */ 1291 if (*p != '<') 1292 { 1293 Tcl_AppendResult(interp, "missing \"<\" in event pattern \"", 1294 pattern, "\"", (char *) NULL); 1295 return TCL_ERROR; 1296 } 1297 p++; 1298 1299 /* Event name (required)*/ 1300 p = GetField(p, eventName, FIELD_SIZE); 1301 1302 if (debug_bindings) 1303 dbwin("GetField='%s'\n", eventName); 1304 1305 /* Terminating > */ 1306 if (*p == '>') 1307 return TCL_OK; 1308 1309 /* Detail name (optional) */ 1310 p = GetField(p, detailName, FIELD_SIZE); 1311 1312 if (debug_bindings) 1313 dbwin("GetField='%s'\n", detailName); 1314 1315 /* Terminating > */ 1316 if (*p != '>') 1317 { 1318 Tcl_AppendResult(interp, "missing \">\" in event pattern \"", 1319 pattern, "\"", (char *) NULL); 1320 return TCL_ERROR; 1321 } 1322 1323 return TCL_OK; 1324} 1325 1326static int ParseEventDescription(BindingTable *bindPtr, char *eventString, 1327 Pattern *patPtr, EventInfo **eventInfoPtr, Detail **detailPtr) 1328{ 1329 Tcl_Interp *interp = bindPtr->interp; 1330 Tcl_HashEntry *hPtr; 1331 char eventName[FIELD_SIZE], detailName[FIELD_SIZE]; 1332 EventInfo *eiPtr; 1333 Detail *dPtr; 1334 char errorMsg[512]; 1335 1336 if (eventInfoPtr) *eventInfoPtr = NULL; 1337 if (detailPtr) *detailPtr = NULL; 1338 1339 patPtr->type = -1; 1340 patPtr->detail = 0; 1341 1342 if (ParseEventDescription1(bindPtr, eventString, eventName, detailName) != TCL_OK) 1343 return TCL_ERROR; 1344 1345 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 1346 if (hPtr == NULL) 1347 { 1348 sprintf(errorMsg, "unknown event \"%.128s\"", eventName); 1349 Tcl_SetResult(interp, errorMsg, TCL_VOLATILE); 1350 return TCL_ERROR; 1351 } 1352 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 1353 patPtr->type = eiPtr->type; 1354 if (eventInfoPtr) *eventInfoPtr = eiPtr; 1355 1356 if (detailName[0] != '\0') 1357 { 1358 /* Find detail for the matching event */ 1359 for (dPtr = eiPtr->detailList; 1360 dPtr != NULL; 1361 dPtr = dPtr->next) 1362 { 1363 if (strcmp(dPtr->name, detailName) == 0) 1364 break; 1365 } 1366 if (dPtr == NULL) 1367 { 1368 sprintf(errorMsg, "unknown detail \"%.128s\" for event \"%.128s\"", 1369 detailName, eiPtr->name); 1370 Tcl_SetResult(interp, errorMsg, TCL_VOLATILE); 1371 return TCL_ERROR; 1372 } 1373 patPtr->detail = dPtr->code; 1374 if (detailPtr) *detailPtr = dPtr; 1375 } 1376 1377 return TCL_OK; 1378} 1379 1380static int FindSequence(BindingTable *bindPtr, ClientData object, 1381 char *eventString, int create, int *created, BindValue **result) 1382{ 1383 Tcl_HashEntry *hPtr; 1384 Pattern pats; 1385 ObjectTableKey key; 1386 BindValue *valuePtr; 1387 int isNew; 1388 1389 if (debug_bindings) 1390 dbwin("FindSequence object='%s' pattern='%s'...\n", (char *) object, 1391 eventString); 1392 1393 if (created) (*created) = 0; 1394 1395 /* Event description -> Pattern */ 1396 if (ParseEventDescription(bindPtr, eventString, &pats, NULL, NULL) != TCL_OK) 1397 return TCL_ERROR; 1398 1399 /* type + detail + object -> BindValue */ 1400 key.type = pats.type; 1401 key.detail = pats.detail; 1402 key.object = object; 1403 if (create) 1404 { 1405 hPtr = Tcl_CreateHashEntry(&bindPtr->objectTable, (char *) &key, &isNew); 1406 1407 if (isNew) 1408 { 1409 if (debug_bindings) 1410 dbwin("New BindValue for '%s' type=%d detail=%d\n", 1411 (char *) object, pats.type, pats.detail); 1412 1413 valuePtr = (BindValue *) Tcl_Alloc(sizeof(BindValue)); 1414 valuePtr->type = pats.type; 1415 valuePtr->detail = pats.detail; 1416 valuePtr->object = object; 1417 valuePtr->command = NULL; 1418 valuePtr->specific = 0; 1419 valuePtr->nextValue = NULL; 1420#if BIND_ACTIVE 1421 /* This binding is active */ 1422 valuePtr->active = 1; 1423#endif /* BIND_ACTIVE */ 1424 Tcl_SetHashValue(hPtr, (ClientData) valuePtr); 1425 } 1426 1427 if (created) (*created) = isNew; 1428 (*result) = (BindValue *) Tcl_GetHashValue(hPtr); 1429 return TCL_OK; 1430 } 1431 1432 /* Look for existing objectTable entry */ 1433 hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) &key); 1434 if (hPtr == NULL) 1435 { 1436 (*result) = NULL; 1437 return TCL_OK; 1438 } 1439 (*result) = (BindValue *) Tcl_GetHashValue(hPtr); 1440 return TCL_OK; 1441} 1442 1443void QE_ExpandDouble(double number, Tcl_DString *result) 1444{ 1445 char numStorage[TCL_DOUBLE_SPACE]; 1446 1447 Tcl_PrintDouble((Tcl_Interp *) NULL, number, numStorage); 1448 Tcl_DStringAppend(result, numStorage, -1); 1449/* QE_ExpandString(numStorage, result); */ 1450} 1451 1452void QE_ExpandNumber(long number, Tcl_DString *result) 1453{ 1454 char numStorage[TCL_INTEGER_SPACE]; 1455 1456 (void) sprintf(numStorage, "%ld", number); 1457 Tcl_DStringAppend(result, numStorage, -1); 1458/* QE_ExpandString(numStorage, result); */ 1459} 1460 1461void QE_ExpandString(char *string, Tcl_DString *result) 1462{ 1463 int length, spaceNeeded, cvtFlags; 1464 1465 spaceNeeded = Tcl_ScanElement(string, &cvtFlags); 1466 length = Tcl_DStringLength(result); 1467 Tcl_DStringSetLength(result, length + spaceNeeded); 1468 spaceNeeded = Tcl_ConvertElement(string, 1469 Tcl_DStringValue(result) + length, 1470 cvtFlags | TCL_DONT_USE_BRACES); 1471 Tcl_DStringSetLength(result, length + spaceNeeded); 1472} 1473 1474void QE_ExpandUnknown(char which, Tcl_DString *result) 1475{ 1476 char string[2]; 1477 1478 (void) sprintf(string, "%c", which); 1479 QE_ExpandString(string, result); 1480} 1481 1482void QE_ExpandEvent(QE_BindingTable bindingTable, int eventType, Tcl_DString *result) 1483{ 1484 BindingTable *bindPtr = (BindingTable *) bindingTable; 1485 EventInfo *eiPtr = FindEvent(bindPtr, eventType); 1486 1487 if (eiPtr != NULL) 1488 QE_ExpandString((char *) eiPtr->name, result); 1489 else 1490 QE_ExpandString("unknown", result); 1491} 1492 1493void QE_ExpandDetail(QE_BindingTable bindingTable, int event, int detail, Tcl_DString *result) 1494{ 1495 BindingTable *bindPtr = (BindingTable *) bindingTable; 1496 Detail *dPtr; 1497 1498 if (detail == 0) 1499 { 1500 QE_ExpandString("", result); 1501 return; 1502 } 1503 1504 dPtr = FindDetail(bindPtr, event, detail); 1505 if (dPtr != NULL) 1506 QE_ExpandString((char *) dPtr->name, result); 1507 else 1508 QE_ExpandString("unknown", result); 1509} 1510 1511void QE_ExpandPattern(QE_BindingTable bindingTable, int eventType, int detail, Tcl_DString *result) 1512{ 1513 BindingTable *bindPtr = (BindingTable *) bindingTable; 1514 EventInfo *eiPtr = FindEvent(bindPtr, eventType); 1515 1516 Tcl_DStringAppend(result, "<", 1); 1517 Tcl_DStringAppend(result, eiPtr ? eiPtr->name : "unknown", -1); 1518 if (detail) 1519 { 1520 Detail *dPtr = FindDetail(bindPtr, eventType, detail); 1521 Tcl_DStringAppend(result, "-", 1); 1522 Tcl_DStringAppend(result, dPtr ? dPtr->name : "unknown", -1); 1523 } 1524 Tcl_DStringAppend(result, ">", 1); 1525} 1526 1527int QE_BindCmd(QE_BindingTable bindingTable, int objOffset, int objc, 1528 Tcl_Obj *CONST objv[]) 1529{ 1530 int objC = objc - objOffset; 1531 Tcl_Obj *CONST *objV = objv + objOffset; 1532 BindingTable *bindPtr = (BindingTable *) bindingTable; 1533 Tk_Window tkwin = Tk_MainWindow(bindPtr->interp); 1534 ClientData object; 1535 char *string; 1536 1537 if ((objC < 1) || (objC > 4)) 1538 { 1539 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, 1540 "?object? ?pattern? ?script?"); 1541 return TCL_ERROR; 1542 } 1543 1544 if (objC == 1) 1545 { 1546 QE_GetAllObjects(bindingTable); 1547 return TCL_OK; 1548 } 1549 1550 string = Tcl_GetString(objV[1]); 1551 1552 if (string[0] == '.') 1553 { 1554 Tk_Window tkwin2; 1555 tkwin2 = Tk_NameToWindow(bindPtr->interp, string, tkwin); 1556 if (tkwin2 == NULL) 1557 { 1558 return TCL_ERROR; 1559 } 1560 object = (ClientData) Tk_GetUid(Tk_PathName(tkwin2)); 1561 } 1562 else 1563 { 1564 object = (ClientData) Tk_GetUid(string); 1565 } 1566 1567 if (objC == 4) 1568 { 1569 int append = 0; 1570 char *sequence = Tcl_GetString(objV[2]); 1571 char *script = Tcl_GetString(objV[3]); 1572 1573 if (script[0] == 0) 1574 { 1575 return QE_DeleteBinding(bindingTable, object, sequence); 1576 } 1577 if (script[0] == '+') 1578 { 1579 script++; 1580 append = 1; 1581 } 1582 return QE_CreateBinding(bindingTable, object, sequence, script, 1583 append); 1584 } 1585 else if (objC == 3) 1586 { 1587 char *sequence = Tcl_GetString(objV[2]); 1588 1589 return QE_GetBinding(bindingTable, object, sequence); 1590 } 1591 else 1592 { 1593 QE_GetAllBindings(bindingTable, object); 1594 } 1595 1596 return TCL_OK; 1597} 1598 1599int QE_UnbindCmd(QE_BindingTable bindingTable, int objOffset, int objc, 1600 Tcl_Obj *CONST objv[]) 1601{ 1602 int objC = objc - objOffset; 1603 Tcl_Obj *CONST *objV = objv + objOffset; 1604 BindingTable *bindPtr = (BindingTable *) bindingTable; 1605 Tk_Window tkwin = Tk_MainWindow(bindPtr->interp); 1606 ClientData object; 1607 char *string, *sequence; 1608 1609 if ((objC < 2) || (objC > 3)) 1610 { 1611 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, 1612 "object ?pattern?"); 1613 return TCL_ERROR; 1614 } 1615 1616 string = Tcl_GetString(objV[1]); 1617 1618 if (string[0] == '.') 1619 { 1620 Tk_Window tkwin2; 1621 tkwin2 = Tk_NameToWindow(bindPtr->interp, string, tkwin); 1622 if (tkwin2 == NULL) 1623 { 1624 return TCL_ERROR; 1625 } 1626 object = (ClientData) Tk_GetUid(Tk_PathName(tkwin2)); 1627 } 1628 else 1629 { 1630 object = (ClientData) Tk_GetUid(string); 1631 } 1632 1633 if (objC == 2) 1634 { 1635 return QE_DeleteBinding(bindingTable, object, NULL); 1636 } 1637 1638 sequence = Tcl_GetString(objV[2]); 1639 return QE_DeleteBinding(bindingTable, object, sequence); 1640} 1641 1642/* 1643 * qegenerate -- Generate events from scripts. 1644 * Usage: qegenerate $pattern ?$charMap? ?$percentsCommand? 1645 * Desciption: Scripts can generate "fake" quasi-events by providing 1646 * a quasi-event pattern and option field/value pairs. 1647 */ 1648 1649int 1650QE_GenerateCmd(QE_BindingTable bindingTable, int objOffset, int objc, 1651 Tcl_Obj *CONST objv[]) 1652{ 1653 int objC = objc - objOffset; 1654 Tcl_Obj *CONST *objV = objv + objOffset; 1655 BindingTable *bindPtr = (BindingTable *) bindingTable; 1656 QE_Event fakeEvent; 1657 EventInfo *eiPtr; 1658 Detail *dPtr; 1659 GenerateData genData; 1660 GenerateField *fieldPtr; 1661 char *p, *t; 1662 int listObjc; 1663 int i; 1664 Tcl_Obj **listObjv; 1665 Pattern pats; 1666 int result; 1667 1668 if (objC < 2 || objC > 4) 1669 { 1670 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, 1671 "pattern ?charMap? ?percentsCommand?"); 1672 return TCL_ERROR; 1673 } 1674 1675 p = Tcl_GetStringFromObj(objV[1], NULL); 1676 if (ParseEventDescription(bindPtr, p, &pats, &eiPtr, &dPtr) != TCL_OK) 1677 return TCL_ERROR; 1678 1679 /* Can't generate an event without a detail */ 1680 if ((dPtr == NULL) && (eiPtr->detailList != NULL)) 1681 { 1682 Tcl_AppendResult(bindPtr->interp, "cannot generate \"", p, 1683 "\": missing detail", (char *) NULL); 1684 return TCL_ERROR; 1685 } 1686 1687 if (objC >= 3) 1688 { 1689 if (Tcl_ListObjGetElements(bindPtr->interp, objV[2], 1690 &listObjc, &listObjv) != TCL_OK) 1691 return TCL_ERROR; 1692 1693 if (listObjc & 1) 1694 { 1695 Tcl_AppendResult(bindPtr->interp, 1696 "char map must have even number of elements", (char *) NULL); 1697 return TCL_ERROR; 1698 } 1699 1700 genData.count = listObjc / 2; 1701 genData.field = genData.staticField; 1702 if (genData.count > sizeof(genData.staticField) / 1703 sizeof(genData.staticField[0])) 1704 { 1705 genData.field = (GenerateField *) Tcl_Alloc(sizeof(GenerateField) * 1706 genData.count); 1707 } 1708 genData.count = 0; 1709 1710 while (listObjc > 1) 1711 { 1712 int length; 1713 1714 t = Tcl_GetStringFromObj(listObjv[0], &length); 1715 if (length != 1) 1716 { 1717 Tcl_AppendResult(bindPtr->interp, "invalid percent char \"", t, 1718 "\"", NULL); 1719 result = TCL_ERROR; 1720 goto done; 1721 } 1722 /* Duplicate %-chars result in last duplicate being used */ 1723 fieldPtr = NULL; 1724 for (i = 0; i < genData.count; i++) 1725 { 1726 if (genData.field[i].which == t[0]) 1727 { 1728 fieldPtr = &genData.field[i]; 1729 break; 1730 } 1731 } 1732 if (fieldPtr == NULL) 1733 fieldPtr = &genData.field[genData.count++]; 1734 fieldPtr->which = t[0]; 1735 fieldPtr->string = Tcl_GetStringFromObj(listObjv[1], NULL); 1736 listObjv += 2; 1737 listObjc -= 2; 1738 } 1739 } 1740 else 1741 { 1742 genData.count = 0; 1743 genData.field = genData.staticField; 1744 } 1745 1746 if (objC == 4) 1747 { 1748 genData.command = Tcl_GetString(objV[3]); 1749 } 1750 else 1751 { 1752 genData.command = NULL; 1753 } 1754 1755 fakeEvent.type = pats.type; 1756 fakeEvent.detail = pats.detail; 1757 fakeEvent.clientData = NULL; 1758 1759 result = BindEventWrapper(bindingTable, &fakeEvent, &genData); 1760 1761done: 1762 if (genData.field != genData.staticField) 1763 Tcl_Free((char *) genData.field); 1764 return result; 1765} 1766 1767#if BIND_ACTIVE 1768 1769/* qeconfigure $win <Term-fresh> -active no */ 1770 1771int 1772QE_ConfigureCmd(QE_BindingTable bindingTable, int objOffset, int objc, 1773 Tcl_Obj *CONST objv[]) 1774{ 1775 int objC = objc - objOffset; 1776 Tcl_Obj *CONST *objV = objv + objOffset; 1777 BindingTable *bindPtr = (BindingTable *) bindingTable; 1778 Tcl_Interp *interp = bindPtr->interp; 1779 Tk_Window tkwin = Tk_MainWindow(interp); 1780 static CONST char *configSwitch[] = {"-active", NULL}; 1781 Tcl_Obj *CONST *objPtr; 1782 BindValue *valuePtr; 1783 char *t, *eventString; 1784 int index; 1785 ClientData object; 1786 1787 if (objC < 3) 1788 { 1789 Tcl_WrongNumArgs(interp, objOffset + 1, objv, 1790 "object pattern ?option? ?value? ?option value ...?"); 1791 return TCL_ERROR; 1792 } 1793 1794 t = Tcl_GetStringFromObj(objV[1], NULL); 1795 eventString = Tcl_GetStringFromObj(objV[2], NULL); 1796 1797 if (t[0] == '.') 1798 { 1799 Tk_Window tkwin2; 1800 tkwin2 = Tk_NameToWindow(interp, t, tkwin); 1801 if (tkwin2 == NULL) 1802 { 1803 return TCL_ERROR; 1804 } 1805 object = (ClientData) Tk_GetUid(Tk_PathName(tkwin2)); 1806 } 1807 else 1808 { 1809 object = (ClientData) Tk_GetUid(t); 1810 } 1811 1812 if (FindSequence(bindPtr, object, eventString, 0, NULL, &valuePtr) != TCL_OK) 1813 return TCL_ERROR; 1814 if (valuePtr == NULL) 1815 return TCL_OK; 1816 1817 objPtr = objv + objOffset + 3; 1818 objc -= objOffset + 3; 1819 1820 if (objc == 0) 1821 { 1822 Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); 1823 Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-active", -1)); 1824 Tcl_ListObjAppendElement(interp, listObj, Tcl_NewBooleanObj(valuePtr->active)); 1825 Tcl_SetObjResult(interp, listObj); 1826 return TCL_OK; 1827 } 1828 1829 if (objc == 1) 1830 { 1831 if (Tcl_GetIndexFromObj(interp, objPtr[0], configSwitch, 1832 "option", 0, &index) != TCL_OK) 1833 { 1834 return TCL_ERROR; 1835 } 1836 switch (index) 1837 { 1838 case 0: /* -active */ 1839 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr->active)); 1840 break; 1841 } 1842 return TCL_OK; 1843 } 1844 1845 while (objc > 1) 1846 { 1847 if (Tcl_GetIndexFromObj(interp, objPtr[0], configSwitch, 1848 "option", 0, &index) != TCL_OK) 1849 { 1850 return TCL_ERROR; 1851 } 1852 switch (index) 1853 { 1854 case 0: /* -active */ 1855 if (Tcl_GetBooleanFromObj(interp, objPtr[1], &valuePtr->active) 1856 != TCL_OK) 1857 { 1858 return TCL_ERROR; 1859 } 1860 break; 1861 } 1862 objPtr += 2; 1863 objc -= 2; 1864 } 1865 1866 return TCL_OK; 1867} 1868 1869#endif /* BIND_ACTIVE */ 1870 1871/* Perform %-substitution with $charMap only */ 1872static void Percents_CharMap(QE_ExpandArgs *args) 1873{ 1874 GenerateData *gdPtr = (GenerateData *) args->clientData; 1875 int i; 1876 1877 for (i = 0; i < gdPtr->count; i++) 1878 { 1879 GenerateField *gfPtr = &gdPtr->field[i]; 1880 if (gfPtr->which == args->which) 1881 { 1882 QE_ExpandString(gfPtr->string, args->result); 1883 return; 1884 } 1885 } 1886 QE_ExpandUnknown(args->which, args->result); 1887} 1888 1889/* Perform %-substitution by calling a Tcl command */ 1890static void Percents_Command(QE_ExpandArgs *args) 1891{ 1892 BindingTable *bindPtr = (BindingTable *) args->bindingTable; 1893 Tcl_Interp *interp = bindPtr->interp; 1894 PercentsData *data = (PercentsData *) args->clientData; 1895 GenerateData *gdPtr = data->gdPtr; 1896 EventInfo *eiPtr = data->eventPtr; 1897 Detail *dPtr = data->detailPtr; 1898 Tcl_DString command; 1899 Tcl_SavedResult state; 1900 int i; 1901 1902 Tcl_DStringInit(&command); 1903 Tcl_DStringAppend(&command, data->command, -1); 1904 Tcl_DStringAppend(&command, " ", 1); 1905 Tcl_DStringAppend(&command, &args->which, 1); 1906 Tcl_DStringAppend(&command, " ", 1); 1907 Tcl_DStringAppend(&command, (char *) args->object, -1); 1908 Tcl_DStringAppend(&command, " ", 1); 1909 Tcl_DStringAppend(&command, eiPtr->name, -1); 1910 Tcl_DStringAppend(&command, " ", 1); 1911 if (dPtr != NULL) 1912 Tcl_DStringAppend(&command, dPtr->name, -1); 1913 else 1914 Tcl_DStringAppend(&command, "{}", -1); 1915 Tcl_DStringStartSublist(&command); 1916 1917 for (i = 0; i < gdPtr->count; i++) 1918 { 1919 GenerateField *genField = &gdPtr->field[i]; 1920 char string[2]; 1921 string[0] = genField->which; 1922 string[1] = '\0'; 1923 Tcl_DStringAppendElement(&command, string); 1924 Tcl_DStringAppendElement(&command, genField->string); 1925 } 1926 1927 Tcl_DStringEndSublist(&command); 1928 Tcl_SaveResult(interp, &state); 1929 if (Tcl_EvalEx(interp, Tcl_DStringValue(&command), 1930 Tcl_DStringLength(&command), TCL_EVAL_GLOBAL) == TCL_OK) 1931 { 1932 QE_ExpandString(Tcl_GetStringFromObj(Tcl_GetObjResult(interp), 1933 NULL), args->result); 1934 } 1935 else 1936 { 1937 QE_ExpandUnknown(args->which, args->result); 1938 Tcl_AddErrorInfo(interp, "\n (expanding percents)"); 1939 Tcl_BackgroundError(interp); 1940 } 1941 Tcl_RestoreResult(interp, &state); 1942 Tcl_DStringFree(&command); 1943} 1944 1945#if ALLOW_INSTALL 1946 1947static int 1948QE_InstallCmd_New(QE_BindingTable bindingTable, int objOffset, int objc, 1949 Tcl_Obj *CONST objv[]) 1950{ 1951 int objC = objc - objOffset; 1952 Tcl_Obj *CONST *objV = objv + objOffset; 1953 BindingTable *bindPtr = (BindingTable *) bindingTable; 1954 char *pattern, *command = NULL; 1955 char eventName[FIELD_SIZE], detailName[FIELD_SIZE]; 1956 int id, length; 1957 EventInfo *eiPtr; 1958 Detail *dPtr = NULL; 1959 Tcl_HashEntry *hPtr; 1960 1961 if (objC < 2 || objC > 3) 1962 { 1963 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "pattern ?percentsCommand?"); 1964 return TCL_ERROR; 1965 } 1966 1967 pattern = Tcl_GetString(objV[1]); 1968 if (ParseEventDescription1(bindPtr, pattern, eventName, detailName) != TCL_OK) 1969 return TCL_ERROR; 1970 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 1971 1972 /* The event is not defined */ 1973 if (hPtr == NULL) 1974 { 1975 id = QE_InstallEvent(bindingTable, eventName, NULL); 1976 if (id == 0) 1977 return TCL_ERROR; 1978 1979 /* Find the event we just installed */ 1980 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 1981 if (hPtr == NULL) 1982 return TCL_ERROR; 1983 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 1984 1985 /* Mark as installed-by-script */ 1986 eiPtr->dynamic = 1; 1987 } 1988 1989 /* The event is already defined */ 1990 else 1991 { 1992 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 1993 } 1994 1995 if (detailName[0]) 1996 { 1997 for (dPtr = eiPtr->detailList; 1998 dPtr != NULL; 1999 dPtr = dPtr->next) 2000 { 2001 if (strcmp(dPtr->name, detailName) == 0) 2002 break; 2003 } 2004 2005 /* The detail is not defined */ 2006 if (dPtr == NULL) 2007 { 2008 /* Define the new detail */ 2009 id = QE_InstallDetail(bindingTable, detailName, eiPtr->type, NULL); 2010 if (id == 0) 2011 return TCL_ERROR; 2012 2013 /* Get the detail we just defined */ 2014 dPtr = FindDetail(bindPtr, eiPtr->type, id); 2015 if (dPtr == NULL) 2016 return TCL_ERROR; 2017 2018 /* Mark as installed-by-script */ 2019 dPtr->dynamic = 1; 2020 } 2021 } 2022 2023 if (objC == 3) 2024 command = Tcl_GetStringFromObj(objV[2], &length); 2025 2026 if (dPtr != NULL) 2027 { 2028 if (!dPtr->dynamic) 2029 { 2030 Tcl_AppendResult(bindPtr->interp, pattern, " is not dynamic", 2031 NULL); 2032 return TCL_ERROR; 2033 } 2034 if (command != NULL) 2035 { 2036 if (dPtr->command) 2037 { 2038 Tcl_Free(dPtr->command); 2039 dPtr->command = NULL; 2040 } 2041 if (length) 2042 { 2043 dPtr->command = Tcl_Alloc(length + 1); 2044 (void) strcpy(dPtr->command, command); 2045 } 2046 } 2047 if (dPtr->command) 2048 Tcl_SetResult(bindPtr->interp, dPtr->command, TCL_VOLATILE); 2049 } 2050 else 2051 { 2052 if (!eiPtr->dynamic) 2053 { 2054 Tcl_AppendResult(bindPtr->interp, pattern, " is not dynamic", 2055 NULL); 2056 return TCL_ERROR; 2057 } 2058 if (command != NULL) 2059 { 2060 if (eiPtr->command) 2061 { 2062 Tcl_Free(eiPtr->command); 2063 eiPtr->command = NULL; 2064 } 2065 if (length) 2066 { 2067 eiPtr->command = Tcl_Alloc(length + 1); 2068 (void) strcpy(eiPtr->command, command); 2069 } 2070 } 2071 if (eiPtr->command) 2072 Tcl_SetResult(bindPtr->interp, eiPtr->command, TCL_VOLATILE); 2073 } 2074 2075 return TCL_OK; 2076} 2077 2078static int 2079QE_InstallCmd_Old(QE_BindingTable bindingTable, int objOffset, int objc, 2080 Tcl_Obj *CONST objv[]) 2081{ 2082 int objC = objc - objOffset; 2083 Tcl_Obj *CONST *objV = objv + objOffset; 2084 BindingTable *bindPtr = (BindingTable *) bindingTable; 2085 static CONST char *commandOption[] = {"detail", "event", NULL}; 2086 int index; 2087 2088 if (objC < 2) 2089 { 2090 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "option arg ..."); 2091 return TCL_ERROR; 2092 } 2093 2094 if (Tcl_GetIndexFromObj(bindPtr->interp, objV[1], 2095 commandOption, "option", 0, &index) != TCL_OK) 2096 { 2097 return TCL_ERROR; 2098 } 2099 switch (index) 2100 { 2101 case 0: /* detail */ 2102 { 2103 char *eventName, *detailName, *command; 2104 int id, length; 2105 Detail *dPtr; 2106 EventInfo *eiPtr; 2107 Tcl_HashEntry *hPtr; 2108 2109 if ((objC < 4) || (objC > 5)) 2110 { 2111 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 2, objv, 2112 "event detail ?percentsCommand?"); 2113 return TCL_ERROR; 2114 } 2115 2116 /* Find the event type */ 2117 eventName = Tcl_GetStringFromObj(objV[2], NULL); 2118 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 2119 if (hPtr == NULL) 2120 { 2121 Tcl_AppendResult(bindPtr->interp, "unknown event \"", 2122 eventName, "\"", NULL); 2123 return TCL_ERROR; 2124 } 2125 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 2126 2127 /* Get the detail name */ 2128 detailName = Tcl_GetStringFromObj(objV[3], NULL); 2129 2130 /* Define the new detail */ 2131 id = QE_InstallDetail(bindingTable, detailName, eiPtr->type, NULL); 2132 if (id == 0) 2133 return TCL_ERROR; 2134 2135 /* Get the detail we just defined */ 2136 dPtr = FindDetail(bindPtr, eiPtr->type, id); 2137 if (dPtr == NULL) 2138 return TCL_ERROR; 2139 dPtr->dynamic = 1; 2140 2141 if (objC == 4) 2142 break; 2143 2144 /* Set the Tcl command for this detail */ 2145 command = Tcl_GetStringFromObj(objV[4], &length); 2146 if (length) 2147 { 2148 dPtr->command = Tcl_Alloc(length + 1); 2149 (void) strcpy(dPtr->command, command); 2150 } 2151 break; 2152 } 2153 2154 case 1: /* event */ 2155 { 2156 char *eventName, *command; 2157 int id, length; 2158 EventInfo *eiPtr; 2159 Tcl_HashEntry *hPtr; 2160 2161 if (objC < 3 || objC > 4) 2162 { 2163 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 2, objv, 2164 "name ?percentsCommand?"); 2165 return TCL_ERROR; 2166 } 2167 2168 eventName = Tcl_GetStringFromObj(objV[2], NULL); 2169 2170 id = QE_InstallEvent(bindingTable, eventName, NULL); 2171 if (id == 0) 2172 return TCL_ERROR; 2173 2174 /* Find the event we just installed */ 2175 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 2176 if (hPtr == NULL) 2177 return TCL_ERROR; 2178 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 2179 2180 /* Mark as installed-by-script */ 2181 eiPtr->dynamic = 1; 2182 2183 if (objC == 3) 2184 break; 2185 2186 /* Set the Tcl command for this event */ 2187 command = Tcl_GetStringFromObj(objV[3], &length); 2188 if (length) 2189 { 2190 eiPtr->command = Tcl_Alloc(length + 1); 2191 (void) strcpy(eiPtr->command, command); 2192 } 2193 break; 2194 } 2195 } 2196 2197 return TCL_OK; 2198} 2199 2200int 2201QE_InstallCmd(QE_BindingTable bindingTable, int objOffset, int objc, 2202 Tcl_Obj *CONST objv[]) 2203{ 2204 int objC = objc - objOffset; 2205 Tcl_Obj *CONST *objV = objv + objOffset; 2206 BindingTable *bindPtr = (BindingTable *) bindingTable; 2207 char *s; 2208 int length; 2209 2210 if (objC < 2) 2211 { 2212 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "pattern ?percentsCommand?"); 2213 return TCL_ERROR; 2214 } 2215 2216 s = Tcl_GetStringFromObj(objV[1], &length); 2217 if (length && (!strcmp(s, "detail") || !strcmp(s, "event"))) 2218 return QE_InstallCmd_Old(bindingTable, objOffset, objc, objv); 2219 2220 return QE_InstallCmd_New(bindingTable, objOffset, objc, objv); 2221} 2222 2223static int 2224QE_UninstallCmd_New(QE_BindingTable bindingTable, int objOffset, int objc, 2225 Tcl_Obj *CONST objv[]) 2226{ 2227 int objC = objc - objOffset; 2228 Tcl_Obj *CONST *objV = objv + objOffset; 2229 BindingTable *bindPtr = (BindingTable *) bindingTable; 2230 char *pattern; 2231 Pattern pats; 2232 EventInfo *eiPtr; 2233 Detail *dPtr; 2234 2235 if (objC != 2) 2236 { 2237 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "pattern"); 2238 return TCL_ERROR; 2239 } 2240 2241 pattern = Tcl_GetString(objV[1]); 2242 if (ParseEventDescription(bindPtr, pattern, &pats, &eiPtr, &dPtr) != TCL_OK) 2243 return TCL_ERROR; 2244 2245 if (dPtr != NULL) 2246 { 2247 if (!dPtr->dynamic) 2248 { 2249 Tcl_AppendResult(bindPtr->interp, 2250 "can't uninstall static detail \"", dPtr->name, "\"", NULL); 2251 return TCL_ERROR; 2252 } 2253 return QE_UninstallDetail(bindingTable, eiPtr->type, dPtr->code); 2254 } 2255 2256 if (!eiPtr->dynamic) 2257 { 2258 Tcl_AppendResult(bindPtr->interp, 2259 "can't uninstall static event \"", eiPtr->name, "\"", NULL); 2260 return TCL_ERROR; 2261 } 2262 2263 return QE_UninstallEvent(bindingTable, eiPtr->type); 2264} 2265 2266static int 2267QE_UninstallCmd_Old(QE_BindingTable bindingTable, int objOffset, int objc, 2268 Tcl_Obj *CONST objv[]) 2269{ 2270 int objC = objc - objOffset; 2271 Tcl_Obj *CONST *objV = objv + objOffset; 2272 BindingTable *bindPtr = (BindingTable *) bindingTable; 2273 static CONST char *commandOption[] = {"detail", "event", NULL}; 2274 int index; 2275 2276 if (objC < 2) 2277 { 2278 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "option arg ..."); 2279 return TCL_ERROR; 2280 } 2281 2282 if (Tcl_GetIndexFromObj(bindPtr->interp, objV[1], 2283 commandOption, "option", 0, &index) != TCL_OK) 2284 { 2285 return TCL_ERROR; 2286 } 2287 2288 switch (index) 2289 { 2290 case 0: /* detail */ 2291 { 2292 char *eventName, *detailName; 2293 Detail *dPtr; 2294 EventInfo *eiPtr; 2295 Tcl_HashEntry *hPtr; 2296 2297 if (objC != 4) 2298 { 2299 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 2, objv, 2300 "event detail"); 2301 return TCL_ERROR; 2302 } 2303 2304 /* Find the event type */ 2305 eventName = Tcl_GetStringFromObj(objV[2], NULL); 2306 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 2307 if (hPtr == NULL) 2308 { 2309 Tcl_AppendResult(bindPtr->interp, "unknown event \"", 2310 eventName, "\"", NULL); 2311 return TCL_ERROR; 2312 } 2313 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 2314 2315 /* Get the detail name */ 2316 detailName = Tcl_GetStringFromObj(objV[3], NULL); 2317 for (dPtr = eiPtr->detailList; 2318 dPtr != NULL; 2319 dPtr = dPtr->next) 2320 { 2321 if (strcmp(dPtr->name, detailName) == 0) 2322 break; 2323 } 2324 if (dPtr == NULL) 2325 { 2326 Tcl_AppendResult(bindPtr->interp, 2327 "unknown detail \"", detailName, "\" for event \"", 2328 eiPtr->name, "\"", NULL); 2329 return TCL_ERROR; 2330 } 2331 2332 if (!dPtr->dynamic) 2333 { 2334 Tcl_AppendResult(bindPtr->interp, 2335 "can't uninstall static detail \"", detailName, "\"", NULL); 2336 return TCL_ERROR; 2337 } 2338 2339 return QE_UninstallDetail(bindingTable, eiPtr->type, dPtr->code); 2340 } 2341 2342 case 1: /* event */ 2343 { 2344 Tcl_HashEntry *hPtr; 2345 EventInfo *eiPtr; 2346 char *eventName; 2347 2348 if (objC != 3) 2349 { 2350 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 2, objv, 2351 "name"); 2352 return TCL_ERROR; 2353 } 2354 2355 /* Find the event type */ 2356 eventName = Tcl_GetStringFromObj(objV[2], NULL); 2357 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 2358 if (hPtr == NULL) 2359 { 2360 Tcl_AppendResult(bindPtr->interp, "unknown event \"", 2361 eventName, "\"", NULL); 2362 return TCL_ERROR; 2363 } 2364 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 2365 2366 if (!eiPtr->dynamic) 2367 { 2368 Tcl_AppendResult(bindPtr->interp, 2369 "can't uninstall static event \"", eventName, "\"", NULL); 2370 return TCL_ERROR; 2371 } 2372 2373 return QE_UninstallEvent(bindingTable, eiPtr->type); 2374 } 2375 } 2376 2377 return TCL_OK; 2378} 2379 2380int QE_UninstallCmd(QE_BindingTable bindingTable, int objOffset, int objc, 2381 Tcl_Obj *CONST objv[]) 2382{ 2383 int objC = objc - objOffset; 2384 Tcl_Obj *CONST *objV = objv + objOffset; 2385 BindingTable *bindPtr = (BindingTable *) bindingTable; 2386 char *s; 2387 int length; 2388 2389 if (objC < 2) 2390 { 2391 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "pattern"); 2392 return TCL_ERROR; 2393 } 2394 2395 s = Tcl_GetStringFromObj(objV[1], &length); 2396 if (length && (!strcmp(s, "detail") || !strcmp(s, "event"))) 2397 return QE_UninstallCmd_Old(bindingTable, objOffset, objc, objv); 2398 2399 return QE_UninstallCmd_New(bindingTable, objOffset, objc, objv); 2400} 2401 2402static int 2403QE_LinkageCmd_New(QE_BindingTable bindingTable, int objOffset, int objc, 2404 Tcl_Obj *CONST objv[]) 2405{ 2406 int objC = objc - objOffset; 2407 Tcl_Obj *CONST *objV = objv + objOffset; 2408 BindingTable *bindPtr = (BindingTable *) bindingTable; 2409 char *pattern; 2410 Pattern pats; 2411 EventInfo *eiPtr; 2412 Detail *dPtr; 2413 2414 if (objC != 2) 2415 { 2416 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "pattern"); 2417 return TCL_ERROR; 2418 } 2419 2420 pattern = Tcl_GetString(objV[1]); 2421 if (ParseEventDescription(bindPtr, pattern, &pats, &eiPtr, &dPtr) != TCL_OK) 2422 return TCL_ERROR; 2423 2424 if (dPtr != NULL) 2425 { 2426 Tcl_SetResult(bindPtr->interp, dPtr->dynamic ? "dynamic" : "static", 2427 TCL_STATIC); 2428 return TCL_OK; 2429 } 2430 2431 Tcl_SetResult(bindPtr->interp, eiPtr->dynamic ? "dynamic" : "static", 2432 TCL_STATIC); 2433 return TCL_OK; 2434} 2435 2436static int 2437QE_LinkageCmd_Old(QE_BindingTable bindingTable, int objOffset, int objc, 2438 Tcl_Obj *CONST objv[]) 2439{ 2440 int objC = objc - objOffset; 2441 Tcl_Obj *CONST *objV = objv + objOffset; 2442 BindingTable *bindPtr = (BindingTable *) bindingTable; 2443 char *eventName, *detailName; 2444 Detail *dPtr; 2445 EventInfo *eiPtr; 2446 Tcl_HashEntry *hPtr; 2447 2448 if (objC < 2 || objC > 3) 2449 { 2450 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "event ?detail?"); 2451 return TCL_ERROR; 2452 } 2453 2454 /* Find the event type */ 2455 eventName = Tcl_GetStringFromObj(objV[1], NULL); 2456 hPtr = Tcl_FindHashEntry(&bindPtr->eventTableByName, eventName); 2457 if (hPtr == NULL) 2458 { 2459 Tcl_AppendResult(bindPtr->interp, "unknown event \"", 2460 eventName, "\"", NULL); 2461 return TCL_ERROR; 2462 } 2463 eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); 2464 2465 if (objC == 2) 2466 { 2467 Tcl_SetResult(bindPtr->interp, eiPtr->dynamic ? "dynamic" : "static", 2468 TCL_STATIC); 2469 return TCL_OK; 2470 } 2471 2472 /* Get the detail name */ 2473 detailName = Tcl_GetStringFromObj(objV[2], NULL); 2474 for (dPtr = eiPtr->detailList; 2475 dPtr != NULL; 2476 dPtr = dPtr->next) 2477 { 2478 if (strcmp(dPtr->name, detailName) == 0) 2479 break; 2480 } 2481 if (dPtr == NULL) 2482 { 2483 Tcl_AppendResult(bindPtr->interp, 2484 "unknown detail \"", detailName, "\" for event \"", 2485 eiPtr->name, "\"", NULL); 2486 return TCL_ERROR; 2487 } 2488 2489 Tcl_SetResult(bindPtr->interp, dPtr->dynamic ? "dynamic" : "static", 2490 TCL_STATIC); 2491 2492 return TCL_OK; 2493} 2494 2495int QE_LinkageCmd(QE_BindingTable bindingTable, int objOffset, int objc, 2496 Tcl_Obj *CONST objv[]) 2497{ 2498 int objC = objc - objOffset; 2499 Tcl_Obj *CONST *objV = objv + objOffset; 2500 BindingTable *bindPtr = (BindingTable *) bindingTable; 2501 char *s; 2502 int length; 2503 2504 if (objC < 2) 2505 { 2506 Tcl_WrongNumArgs(bindPtr->interp, objOffset + 1, objv, "pattern"); 2507 return TCL_ERROR; 2508 } 2509 2510 s = Tcl_GetStringFromObj(objV[1], &length); 2511 if ((objC == 3) || (length && s[0] != '<')) 2512 return QE_LinkageCmd_Old(bindingTable, objOffset, objc, objv); 2513 2514 return QE_LinkageCmd_New(bindingTable, objOffset, objc, objv); 2515} 2516 2517#endif /* ALLOW_INSTALL */ 2518 2519