1/* struct::tree - critcl - layer 3 definitions. 2 * 3 * -> Method functions. 4 * Implementations for all tree methods. 5 */ 6 7#include <string.h> 8#include "util.h" 9#include "m.h" 10#include "t.h" 11#include "tn.h" 12#include "ms.h" 13 14/* .................................................. 15 * Handling of all indices, numeric and 'end-x' forms. Copied straight out of 16 * the Tcl core as this is not exported through the public API. 17 */ 18 19static int TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, 20 int endValue, int* indexPtr); 21 22/* .................................................. */ 23 24/* 25 *--------------------------------------------------------------------------- 26 * 27 * tm_TASSIGN -- 28 * 29 * Copies the argument tree over into this tree object. Uses direct 30 * access to internal data structures for matching tree objects, and 31 * goes through a serialize/deserialize combination otherwise. 32 * 33 * Results: 34 * A standard Tcl result code. 35 * 36 * Side effects: 37 * Only internal, memory allocation changes ... 38 * 39 *--------------------------------------------------------------------------- 40 */ 41 42int 43tm_TASSIGN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 44{ 45 /* Syntax: tree = source 46 * [0] [1] [2] 47 */ 48 49 if (objc != 3) { 50 Tcl_WrongNumArgs (interp, 2, objv, "source"); 51 return TCL_ERROR; 52 } 53 54 return tms_assign (interp, t, objv [2]); 55} 56 57/* 58 *--------------------------------------------------------------------------- 59 * 60 * tm_TSET -- 61 * 62 * Copies this tree over into the argument tree. Uses direct access to 63 * internal data structures for matching tree objects, and goes through a 64 * serialize/deserialize combination otherwise. 65 * 66 * Results: 67 * A standard Tcl result code. 68 * 69 * Side effects: 70 * Only internal, memory allocation changes ... 71 * 72 *--------------------------------------------------------------------------- 73 */ 74 75int 76tm_TSET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 77{ 78 /* Syntax: tree --> dest(ination) 79 * [0] [1] [2] 80 */ 81 82 if (objc != 3) { 83 Tcl_WrongNumArgs (interp, 2, objv, "dest"); 84 return TCL_ERROR; 85 } 86 87 return tms_set (interp, t, objv [2]); 88} 89 90/* 91 *--------------------------------------------------------------------------- 92 * 93 * tm_ANCESTORS -- 94 * 95 * Returns a list containing the ancestors of the named node. 96 * 97 * Results: 98 * A standard Tcl result code. 99 * 100 * Side effects: 101 * May release and allocate memory. 102 * 103 *--------------------------------------------------------------------------- 104 */ 105 106int 107tm_ANCESTORS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 108{ 109 /* Syntax: tree ancestors node 110 * [0] [1] [2] 111 */ 112 113 TN* tn; 114 Tcl_Obj* res; 115 int depth; 116 117 if (objc != 3) { 118 Tcl_WrongNumArgs (interp, 2, objv, "node"); 119 return TCL_ERROR; 120 } 121 122 tn = tn_get_node (t, objv [2], interp, objv [0]); 123 if (tn == NULL) { 124 return TCL_ERROR; 125 } 126 127 depth = tn_depth (tn); 128 if (depth == 0) { 129 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 130 } else { 131 int i; 132 Tcl_Obj** anc = NALLOC (depth, Tcl_Obj*); 133 134 for (i = 0; 135 tn->parent != NULL; 136 i++, tn = tn->parent) { 137 138 ASSERT_BOUNDS (i, depth); 139 140 anc [i] = tn->parent->name; 141 /* RefCount++ happens in NewList */ 142 /*Tcl_IncrRefCount (anc [i]);*/ 143 } 144 145 Tcl_SetObjResult (interp, Tcl_NewListObj (i, anc)); 146 ckfree ((char*) anc); 147 } 148 149 return TCL_OK; 150} 151 152/* 153 *--------------------------------------------------------------------------- 154 * 155 * tm_APPEND -- 156 * 157 * Appends a value to an attribute of the named node. 158 * May create the attribute. 159 * 160 * Results: 161 * A standard Tcl result code. 162 * 163 * Side effects: 164 * May release and allocate memory. 165 * 166 *--------------------------------------------------------------------------- 167 */ 168 169int 170tm_APPEND (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 171{ 172 /* Syntax: tree append node key value 173 * [0] [1] [2] [3] [4] 174 */ 175 176 TN* tn; 177 Tcl_HashEntry* he; 178 CONST char* key; 179 180 if (objc != 5) { 181 Tcl_WrongNumArgs (interp, 2, objv, "node key value"); 182 return TCL_ERROR; 183 } 184 185 tn = tn_get_node (t, objv [2], interp, objv [0]); 186 if (tn == NULL) { 187 return TCL_ERROR; 188 } 189 190 key = Tcl_GetString (objv [3]); 191 192 tn_extend_attr (tn); 193 194 he = Tcl_FindHashEntry (tn->attr, key); 195 196 if (he == NULL) { 197 int new; 198 he = Tcl_CreateHashEntry(tn->attr, key, &new); 199 200 Tcl_IncrRefCount (objv [4]); 201 Tcl_SetHashValue (he, (ClientData) objv [4]); 202 Tcl_SetObjResult (interp, objv [4]); 203 } else { 204 Tcl_Obj* av = (Tcl_Obj*) Tcl_GetHashValue(he); 205 206 if (Tcl_IsShared (av)) { 207 Tcl_DecrRefCount (av); 208 av = Tcl_DuplicateObj (av); 209 Tcl_IncrRefCount (av); 210 211 Tcl_SetHashValue (he, (ClientData) av); 212 } 213 214 Tcl_AppendObjToObj (av, objv [4]); 215 Tcl_SetObjResult (interp, av); 216 } 217 218 return TCL_OK; 219} 220 221/* 222 *--------------------------------------------------------------------------- 223 * 224 * tm_ATTR -- 225 * 226 * Returns a dictionary mapping from nodes to attribute values, for a 227 * named attribute. 228 * 229 * Results: 230 * A standard Tcl result code. 231 * 232 * Side effects: 233 * May release and allocate memory. 234 * 235 *--------------------------------------------------------------------------- 236 */ 237 238int 239tm_ATTR (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 240{ 241 /* Syntax: tree attr key ?-query queryarg? 242 * : -nodes nodelist 243 * : -glob nodepattern 244 * : -regexp nodepattern 245 * [0] [1] [2] [3] [4] 246 */ 247 248 CONST char* key; 249 int type; 250 Tcl_Obj* detail = NULL; 251 int listc = 0; 252 Tcl_Obj** listv = NULL; 253 254 CONST char* types [] = { 255 "-glob", "-nodes","-regexp", NULL 256 }; 257 enum types { 258 T_GLOB, T_NODES, T_REGEXP, T_NONE 259 }; 260 261 if ((objc != 3) && (objc != 5)) { 262 Tcl_WrongNumArgs (interp, 2, objv, 263 "key ?-nodes list|-glob pattern|-regexp pattern?"); 264 return TCL_ERROR; 265 } 266 267 key = Tcl_GetString (objv [2]); 268 269 if (objc != 5) { 270 type = T_NONE; 271 } else { 272 detail = objv [4]; 273 if (Tcl_GetIndexFromObj (interp, objv [3], types, "type", 274 0, &type) != TCL_OK) { 275 Tcl_ResetResult (interp); 276 Tcl_WrongNumArgs (interp, 2, objv, 277 "key ?-nodes list|-glob pattern|-regexp pattern?"); 278 return TCL_ERROR; 279 } 280 } 281 282 /* Allocate result space, max needed: All nodes */ 283 284 ASSERT (t->node.numEntries == t->nnodes, "Inconsistent #nodes in tree"); 285 286 switch (type) { 287 case T_GLOB: 288 { 289 /* Iterate over all nodes 290 * Ignore nodes without attributes 291 * Ignore nodes not matching the pattern (glob) 292 * Ignore nodes not having the attribute 293 */ 294 295 int i; 296 TN* iter; 297 CONST char* pattern = Tcl_GetString (detail); 298 Tcl_HashEntry* he; 299 300 listc = 2 * t->node.numEntries; 301 listv = NALLOC (listc, Tcl_Obj*); 302 303 for (i = 0, iter = t->nodes; 304 iter != NULL; 305 iter= iter->nextnode) { 306 307 if (!iter->attr) continue; 308 if (!iter->attr->numEntries) continue; 309 if (!Tcl_StringMatch(Tcl_GetString (iter->name), pattern)) continue; 310 311 he = Tcl_FindHashEntry (iter->attr, key); 312 if (!he) continue; 313 314 ASSERT_BOUNDS (i, listc); 315 ASSERT_BOUNDS (i+1, listc); 316 317 listv [i++] = iter->name; 318 listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); 319 } 320 321 listc = i; 322 } 323 break; 324 325 case T_NODES: 326 { 327 /* Iterate over the specified nodes 328 * Ignore nodes which are not known 329 * Ignore nodes without attributes 330 * Ignore nodes not having the attribute 331 * Many occurrences of the same node cause 332 * repeated results. 333 */ 334 335 TN* iter; 336 int nodec; 337 Tcl_Obj** nodev; 338 int i, j; 339 Tcl_HashEntry* he; 340 341 if (Tcl_ListObjGetElements (interp, detail, &nodec, &nodev) != TCL_OK) { 342 return TCL_ERROR; 343 } 344 345 if (nodec > t->nnodes) { 346 listc = 2 * nodec; 347 } else { 348 listc = 2 * t->nnodes; 349 } 350 listv = NALLOC (listc, Tcl_Obj*); 351 352 for (i = 0, j = 0; i < nodec; i++) { 353 354 ASSERT_BOUNDS (i, nodec); 355 iter = tn_get_node (t, nodev [i], NULL, NULL); 356 357 if (iter == NULL) continue; 358 if (!iter->attr) continue; 359 if (!iter->attr->numEntries) continue; 360 361 he = Tcl_FindHashEntry (iter->attr, key); 362 if (!he) continue; 363 364 ASSERT_BOUNDS (j, listc); 365 ASSERT_BOUNDS (j+1, listc); 366 367 listv [j++] = iter->name; 368 listv [j++] = (Tcl_Obj*) Tcl_GetHashValue(he); 369 } 370 371 listc = j; 372 } 373 break; 374 375 case T_REGEXP: 376 { 377 /* Iterate over all nodes 378 * Ignore nodes without attributes 379 * Ignore nodes not matching the pattern (re) 380 * Ignore nodes not having the attribute 381 */ 382 383 int i; 384 TN* iter; 385 CONST char* pattern = Tcl_GetString (detail); 386 Tcl_HashEntry* he; 387 388 listc = 2 * t->node.numEntries; 389 listv = NALLOC (listc, Tcl_Obj*); 390 391 for (i = 0, iter = t->nodes; 392 iter != NULL; 393 iter= iter->nextnode) { 394 395 if (!iter->attr) continue; 396 if (!iter->attr->numEntries) continue; 397 if (Tcl_RegExpMatch(interp, Tcl_GetString (iter->name), pattern) < 1) continue; 398 399 he = Tcl_FindHashEntry (iter->attr, key); 400 if (!he) continue; 401 402 ASSERT_BOUNDS (i, listc); 403 ASSERT_BOUNDS (i+1, listc); 404 405 listv [i++] = iter->name; 406 listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); 407 } 408 409 listc = i; 410 } 411 break; 412 413 case T_NONE: 414 { 415 /* Iterate over all nodes 416 * Ignore nodes without attributes 417 * Ignore nodes not having the attribute 418 */ 419 420 int i; 421 TN* iter; 422 Tcl_HashEntry* he; 423 424 listc = 2 * t->node.numEntries; 425 listv = NALLOC (listc, Tcl_Obj*); 426 427 for (i = 0, iter = t->nodes; 428 iter != NULL; 429 iter= iter->nextnode) { 430 431 if (!iter->attr) continue; 432 if (!iter->attr->numEntries) continue; 433 434 he = Tcl_FindHashEntry (iter->attr, key); 435 if (!he) continue; 436 437 ASSERT_BOUNDS (i, listc); 438 ASSERT_BOUNDS (i+1, listc); 439 440 listv [i++] = iter->name; 441 listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); 442 } 443 444 listc = i; 445 } 446 break; 447 } 448 449 if (listc) { 450 Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); 451 } else { 452 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 453 } 454 455 ckfree ((char*) listv); 456 return TCL_OK; 457} 458 459/* 460 *--------------------------------------------------------------------------- 461 * 462 * tm_CHILDREN -- 463 * 464 * Returns a list of all direct or indirect descendants of the named 465 * node, possibly run through a Tcl command prefix for filtering. 466 * 467 * Results: 468 * A standard Tcl result code. 469 * 470 * Side effects: 471 * May release and allocate memory. Per the filter command prefix, if 472 * one has been specified. 473 * 474 *--------------------------------------------------------------------------- 475 */ 476 477int 478tm_CHILDREN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 479{ 480 /* Syntax: tree children ?-all? node ?filter cmdpfx? 481 * 3 tree children node 482 * 4 tree children -all node 483 * 5 tree children node filter cmdpfx 484 * 6 tree children -all node filter cmdpfx 485 * [0] [1] [2] [3] [4] [5] 486 */ 487 488#undef USAGE 489#define USAGE "?-all? node ?filter cmd?" 490 491 TN* tn; 492 int node = 2; 493 int all = 0; 494 int cmdc = 0; 495 Tcl_Obj** cmdv = NULL; 496 int listc = 0; 497 Tcl_Obj** listv; 498 499 if ((objc < 3) || (objc > 6)) { 500 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 501 return TCL_ERROR; 502 } 503 504 ASSERT_BOUNDS (node, objc); 505 if (0 == strcmp ("-all", Tcl_GetString (objv [node]))) { 506 /* -all present */ 507 508 if ((objc != 4) && (objc != 6)) { 509 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 510 return TCL_ERROR; 511 } 512 513 node ++; 514 all = 1; 515 } else { 516 /* -all missing */ 517 518 if ((objc != 3) && (objc != 5)) { 519 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 520 return TCL_ERROR; 521 } 522 } 523 524 if (objc == (node+3)) { 525 ASSERT_BOUNDS (node+1, objc); 526 if (strcmp ("filter", Tcl_GetString (objv [node+1]))) { 527 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 528 return TCL_ERROR; 529 } 530 531 ASSERT_BOUNDS (node+2, objc); 532 if (Tcl_ListObjGetElements (interp, objv [node+2], &cmdc, &cmdv) != TCL_OK) { 533 return TCL_ERROR; 534 } 535 if (!cmdc) { 536 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 537 return TCL_ERROR; 538 } 539 } 540 541 ASSERT_BOUNDS (node, objc); 542 tn = tn_get_node (t, objv [node], interp, objv [0]); 543 if (tn == NULL) { 544 return TCL_ERROR; 545 } 546 547 return tms_getchildren (tn, all, 548 cmdc, cmdv, 549 objv [0], interp); 550} 551 552/* 553 *--------------------------------------------------------------------------- 554 * 555 * tm_CUT -- 556 * 557 * Deletes the named nodes, but not its children. They are put into the 558 * place where the deleted node was. Complementary to tm_SPLICE. 559 * 560 * Results: 561 * A standard Tcl result code. 562 * 563 * Side effects: 564 * May release and allocate memory. 565 * 566 *--------------------------------------------------------------------------- 567 */ 568 569int 570tm_CUT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 571{ 572 /* Syntax: tree cut node 573 * [0] [1] [2] 574 */ 575 576 TN* tn; 577 TN* p; 578 Tcl_Obj* res; 579 int i, j; 580 TN** child; 581 int nchildren; 582 583 if (objc != 3) { 584 Tcl_WrongNumArgs (interp, 2, objv, "node"); 585 return TCL_ERROR; 586 } 587 588 tn = tn_get_node (t, objv [2], interp, objv [0]); 589 if (tn == NULL) { 590 return TCL_ERROR; 591 } 592 593 if (tn == t->root) { 594 /* Node found, is root, cannot be cut */ 595 596 Tcl_AppendResult (interp, "cannot cut root node", NULL); 597 return TCL_ERROR; 598 } 599 600 tn_cut (tn); 601 return TCL_OK; 602} 603 604/* 605 *--------------------------------------------------------------------------- 606 * 607 * tm_DELETE -- 608 * 609 * Deletes the named node and its children. 610 * 611 * Results: 612 * A standard Tcl result code. 613 * 614 * Side effects: 615 * May release and allocate memory. 616 * 617 *--------------------------------------------------------------------------- 618 */ 619 620int 621tm_DELETE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 622{ 623 /* Syntax: tree delete node 624 * [0] [1] [2] 625 */ 626 627 TN* tn; 628 Tcl_Obj* res; 629 630 if (objc != 3) { 631 Tcl_WrongNumArgs (interp, 2, objv, "node"); 632 return TCL_ERROR; 633 } 634 635 tn = tn_get_node (t, objv [2], interp, objv [0]); 636 if (tn == NULL) { 637 return TCL_ERROR; 638 } 639 640 if (tn == t->root) { 641 /* Node found, is root, cannot be deleted */ 642 643 Tcl_AppendResult (interp, "cannot delete root node", NULL); 644 return TCL_ERROR; 645 } 646 647 tn_detach (tn); 648 tn_delete (tn); 649 return TCL_OK; 650} 651 652/* 653 *--------------------------------------------------------------------------- 654 * 655 * tm_DEPTH -- 656 * 657 * Returns a non-negative integer number describing the distance between 658 * the named node and the root of the tree. A depth of 0 implies that 659 * the node is the root node. 660 * 661 * Results: 662 * A standard Tcl result code. 663 * 664 * Side effects: 665 * May release and allocate memory. 666 * 667 *--------------------------------------------------------------------------- 668 */ 669 670int 671tm_DEPTH (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 672{ 673 /* Syntax: tree depth node 674 * [0] [1] [2] 675 */ 676 677 TN* tn; 678 Tcl_Obj* res; 679 680 if (objc != 3) { 681 Tcl_WrongNumArgs (interp, 2, objv, "node"); 682 return TCL_ERROR; 683 } 684 685 tn = tn_get_node (t, objv [2], interp, objv [0]); 686 if (tn == NULL) { 687 return TCL_ERROR; 688 } 689 690 Tcl_SetObjResult (interp, Tcl_NewIntObj (tn_depth (tn))); 691 return TCL_OK; 692} 693 694/* 695 *--------------------------------------------------------------------------- 696 * 697 * tm_DESCENDANTS -- 698 * 699 * Returns a list of all descendants of the named node, possibly run 700 * through a Tcl command prefix for filtering. 701 * 702 * Results: 703 * A standard Tcl result code. 704 * 705 * Side effects: 706 * May release and allocate memory. Per the filter command prefix, if 707 * one has been specified. 708 * 709 *--------------------------------------------------------------------------- 710 */ 711 712int 713tm_DESCENDANTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 714{ 715 /* Syntax: tree descendants node ?filter cmdprefix? 716 * [0] [1] [2] [3] [4] 717 */ 718 719 TN* tn; 720 int cmdc = 0; 721 Tcl_Obj** cmdv = NULL; 722 723 if ((objc < 2) || (objc > 5)) { 724 Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?"); 725 return TCL_ERROR; 726 } 727 728 if (objc == 5) { 729 if (strcmp ("filter", Tcl_GetString (objv [3]))) { 730 Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?"); 731 return TCL_ERROR; 732 } 733 if (Tcl_ListObjGetElements (interp, objv [4], &cmdc, &cmdv) != TCL_OK) { 734 return TCL_ERROR; 735 } 736 if (!cmdc) { 737 Tcl_WrongNumArgs (interp, 2, objv, "node ?filter cmd?"); 738 return TCL_ERROR; 739 } 740 } 741 742 tn = tn_get_node (t, objv [2], interp, objv [0]); 743 if (tn == NULL) { 744 return TCL_ERROR; 745 } 746 747 return tms_getchildren (tn, 1 /* all */, 748 cmdc, cmdv, 749 objv [0], interp); 750} 751 752/* 753 *--------------------------------------------------------------------------- 754 * 755 * tm_DESERIALIZE -- 756 * 757 * Parses a Tcl value containing a serialized tree and copies it over 758 * he existing tree. 759 * 760 * Results: 761 * A standard Tcl result code. 762 * 763 * Side effects: 764 * May release and allocate memory. 765 * 766 *--------------------------------------------------------------------------- 767 */ 768 769int 770tm_DESERIALIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 771{ 772 /* Syntax: tree deserialize serial 773 * [0] [1] [2] 774 */ 775 776 T* tser; 777 778 if (objc != 3) { 779 Tcl_WrongNumArgs (interp, 2, objv, "serial"); 780 return TCL_ERROR; 781 } 782 783 return t_deserialize (t, interp, objv [2]); 784} 785 786/* 787 *--------------------------------------------------------------------------- 788 * 789 * tm_DESTROY -- 790 * 791 * Destroys the whole tree object. 792 * 793 * Results: 794 * A standard Tcl result code. 795 * 796 * Side effects: 797 * Releases memory. 798 * 799 *--------------------------------------------------------------------------- 800 */ 801 802int 803tm_DESTROY (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 804{ 805 /* Syntax: tree destroy 806 * [0] [1] 807 */ 808 809 if (objc != 2) { 810 Tcl_WrongNumArgs (interp, 2, objv, NULL); 811 return TCL_ERROR; 812 } 813 814 Tcl_DeleteCommandFromToken(interp, t->cmd); 815 return TCL_OK; 816} 817 818/* 819 *--------------------------------------------------------------------------- 820 * 821 * tm_EXISTS -- 822 * 823 * Returns a boolean value signaling whether the named node exists in 824 * the tree. True implies existence, and false non-existence. 825 * 826 * Results: 827 * A standard Tcl result code. 828 * 829 * Side effects: 830 * May release and allocate memory. 831 * 832 *--------------------------------------------------------------------------- 833 */ 834 835int 836tm_EXISTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 837{ 838 /* Syntax: tree exists node 839 * [0] [1] [2] 840 */ 841 842 TN* tn; 843 Tcl_Obj* res; 844 845 if (objc != 3) { 846 Tcl_WrongNumArgs (interp, 2, objv, "node"); 847 return TCL_ERROR; 848 } 849 850 tn = tn_get_node (t, objv [2], NULL, NULL); 851 852 Tcl_SetObjResult (interp, Tcl_NewIntObj (tn != NULL)); 853 return TCL_OK; 854} 855 856/* 857 *--------------------------------------------------------------------------- 858 * 859 * tm_GET -- 860 * 861 * Returns the value of the named attribute at the given node. 862 * 863 * Results: 864 * A standard Tcl result code. 865 * 866 * Side effects: 867 * May release and allocate memory. 868 * 869 *--------------------------------------------------------------------------- 870 */ 871 872int 873tm_GET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 874{ 875 /* Syntax: tree get node key 876 * [0] [1] [2] [3] 877 */ 878 879 TN* tn; 880 Tcl_HashEntry* he = NULL; 881 CONST char* key; 882 Tcl_Obj* av; 883 884 if (objc != 4) { 885 Tcl_WrongNumArgs (interp, 2, objv, "node key"); 886 return TCL_ERROR; 887 } 888 889 tn = tn_get_node (t, objv [2], interp, objv [0]); 890 if (tn == NULL) { 891 return TCL_ERROR; 892 } 893 894 key = Tcl_GetString (objv [3]); 895 896 if (tn->attr) { 897 he = Tcl_FindHashEntry (tn->attr, key); 898 } 899 900 if ((tn->attr == NULL) || (he == NULL)) { 901 Tcl_Obj* err = Tcl_NewObj (); 902 903 Tcl_AppendToObj (err, "invalid key \"", -1); 904 Tcl_AppendObjToObj (err, objv [3]); 905 Tcl_AppendToObj (err, "\" for node \"", -1); 906 Tcl_AppendObjToObj (err, objv [2]); 907 Tcl_AppendToObj (err, "\"", -1); 908 909 Tcl_SetObjResult (interp, err); 910 return TCL_ERROR; 911 } 912 913 av = (Tcl_Obj*) Tcl_GetHashValue(he); 914 Tcl_SetObjResult (interp, av); 915 return TCL_OK; 916} 917 918/* 919 *--------------------------------------------------------------------------- 920 * 921 * tm_GETALL -- 922 * 923 * Returns a dictionary containing all attributes and their values of 924 * the specified node. 925 * 926 * Results: 927 * A standard Tcl result code. 928 * 929 * Side effects: 930 * May release and allocate memory. 931 * 932 *--------------------------------------------------------------------------- 933 */ 934 935int 936tm_GETALL (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 937{ 938 /* Syntax: tree getall node ?pattern? 939 * [0] [1] [2] [3] 940 */ 941 942 TN* tn; 943 Tcl_HashEntry* he; 944 Tcl_HashSearch hs; 945 CONST char* key; 946 int i; 947 int listc; 948 Tcl_Obj** listv; 949 CONST char* pattern = NULL; 950 int matchall = 0; 951 952 if ((objc != 3) && (objc != 4)) { 953 Tcl_WrongNumArgs (interp, 2, objv, "node ?pattern?"); 954 return TCL_ERROR; 955 } 956 957 tn = tn_get_node (t, objv [2], interp, objv [0]); 958 if (tn == NULL) { 959 return TCL_ERROR; 960 } 961 962 if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) { 963 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 964 return TCL_OK; 965 } 966 967 if (objc == 4) { 968 pattern = Tcl_GetString (objv [3]); 969 matchall = (strcmp (pattern, "*") == 0); 970 } 971 972 listc = 2 * tn->attr->numEntries; 973 listv = NALLOC (listc, Tcl_Obj*); 974 975 if ((objc == 3) || matchall) { 976 /* Unpatterned retrieval, or pattern '*' */ 977 978 for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); 979 he != NULL; 980 he = Tcl_NextHashEntry(&hs)) { 981 982 key = Tcl_GetHashKey (tn->attr, he); 983 984 ASSERT_BOUNDS (i, listc); 985 ASSERT_BOUNDS (i+1, listc); 986 987 listv [i++] = Tcl_NewStringObj (key, -1); 988 listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); 989 } 990 991 ASSERT (i == listc, "Bad attribute retrieval"); 992 } else { 993 /* Filtered retrieval, glob pattern */ 994 995 for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); 996 he != NULL; 997 he = Tcl_NextHashEntry(&hs)) { 998 999 key = Tcl_GetHashKey (tn->attr, he); 1000 1001 if (Tcl_StringMatch(key, pattern)) { 1002 ASSERT_BOUNDS (i, listc); 1003 ASSERT_BOUNDS (i+1, listc); 1004 1005 listv [i++] = Tcl_NewStringObj (key, -1); 1006 listv [i++] = (Tcl_Obj*) Tcl_GetHashValue(he); 1007 } 1008 } 1009 1010 ASSERT (i <= listc, "Bad attribute glob retrieval"); 1011 listc = i; 1012 } 1013 1014 if (listc) { 1015 Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); 1016 } else { 1017 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 1018 } 1019 1020 ckfree ((char*) listv); 1021 return TCL_OK; 1022} 1023 1024/* 1025 *--------------------------------------------------------------------------- 1026 * 1027 * tm_HEIGHT -- 1028 * 1029 * Returns a non-negative integer number describing the distance between 1030 * the given node and its farthest child. A value of 0 implies that the 1031 * node is a leaf. 1032 * 1033 * Results: 1034 * A standard Tcl result code. 1035 * 1036 * Side effects: 1037 * May release and allocate memory. 1038 * 1039 *--------------------------------------------------------------------------- 1040 */ 1041 1042int 1043tm_HEIGHT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1044{ 1045 /* Syntax: tree height node 1046 * [0] [1] [2] 1047 */ 1048 1049 TN* tn; 1050 Tcl_Obj* res; 1051 1052 if (objc != 3) { 1053 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1054 return TCL_ERROR; 1055 } 1056 1057 tn = tn_get_node (t, objv [2], interp, objv [0]); 1058 if (tn == NULL) { 1059 return TCL_ERROR; 1060 } 1061 1062 Tcl_SetObjResult (interp, Tcl_NewIntObj (tn_height (tn))); 1063 return TCL_OK; 1064} 1065 1066/* 1067 *--------------------------------------------------------------------------- 1068 * 1069 * tm_INDEX -- 1070 * 1071 * Returns a non-negative integer number describing the location of the 1072 * specified node within its parent's list of children. An index of 0 1073 * implies that the node is the left-most child of its parent. 1074 * 1075 * Results: 1076 * A standard Tcl result code. 1077 * 1078 * Side effects: 1079 * May release and allocate memory. 1080 * 1081 *--------------------------------------------------------------------------- 1082 */ 1083 1084int 1085tm_INDEX (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1086{ 1087 /* Syntax: tree index node 1088 * [0] [1] [2] 1089 */ 1090 1091 TN* tn; 1092 Tcl_Obj* res; 1093 1094 if (objc != 3) { 1095 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1096 return TCL_ERROR; 1097 } 1098 1099 tn = tn_get_node (t, objv [2], interp, objv [0]); 1100 if (tn == NULL) { 1101 return TCL_ERROR; 1102 } 1103 1104 if (tn == tn->tree->root) { 1105 Tcl_AppendResult (interp, "cannot determine index of root node", NULL); 1106 return TCL_ERROR; 1107 } 1108 1109 Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->index)); 1110 return TCL_OK; 1111} 1112 1113/* 1114 *--------------------------------------------------------------------------- 1115 * 1116 * tm_INSERT -- 1117 * 1118 * Creates/inserts/moves a node to specific location in its (new) parent. 1119 * 1120 * Results: 1121 * A standard Tcl result code. 1122 * 1123 * Side effects: 1124 * May release and allocate memory. 1125 * 1126 *--------------------------------------------------------------------------- 1127 */ 1128 1129int 1130tm_INSERT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1131{ 1132 /* Syntax: tree insert parent index ?name...? 1133 * [0] [1] [2] [3] [4+] 1134 */ 1135 1136 TN* tn; 1137 int idx; 1138 Tcl_Obj* res; 1139 1140 if (objc < 4) { 1141 Tcl_WrongNumArgs (interp, 2, objv, "parent index ?name...?"); 1142 return TCL_ERROR; 1143 } 1144 1145 Tcl_AppendResult (interp, "parent ", NULL); 1146 tn = tn_get_node (t, objv [2], interp, objv [0]); 1147 if (tn == NULL) { 1148 return TCL_ERROR; 1149 } 1150 Tcl_ResetResult (interp); 1151 1152 if (TclGetIntForIndex (interp, objv [3], tn->nchildren, &idx) != TCL_OK) { 1153 return TCL_ERROR; 1154 } 1155 1156 if (objc > 4) { 1157 /* We have explicit node names. */ 1158 /* Unknown nodes are created. */ 1159 /* Existing nodes are moved. */ 1160 /* Trying to move the root will fail. */ 1161 1162 int i; 1163 TN* n; 1164 1165 for (i = 4; i < objc; i++) { 1166 ASSERT_BOUNDS (i, objc); 1167 n = tn_get_node (t, objv [i], NULL, NULL); 1168 1169 if (n == NULL) { 1170 /* No matching node found */ 1171 /* Create node with specified name, */ 1172 /* then insert it */ 1173 1174 CONST char* name; 1175 name = Tcl_GetString (objv [i]); 1176 1177 tn_insert (tn, idx, tn_new (t, name)); 1178 idx++; 1179 1180 } else if (n == t->root) { 1181 /* Node found, is root, immovable */ 1182 1183 Tcl_AppendResult (interp, "cannot move root node", NULL); 1184 return TCL_ERROR; 1185 1186 } else if ((n == tn) || tn_isancestorof (n, tn)) { 1187 /* Node found, not root, but move is irregular */ 1188 1189 /* The chosen parent is actually a descendant of the */ 1190 /* node to move. The move would create a circle. This */ 1191 /* is not allowed. */ 1192 1193 Tcl_Obj* err = Tcl_NewObj (); 1194 1195 Tcl_AppendToObj (err, "node \"", -1); 1196 Tcl_AppendObjToObj (err, objv [i]); 1197 Tcl_AppendToObj (err, "\" cannot be its own descendant", -1); 1198 1199 Tcl_SetObjResult (interp, err); 1200 return TCL_ERROR; 1201 1202 } else { 1203 /* Node found, move is ok */ 1204 1205 /* If the node is moving within its parent, and its */ 1206 /* old location was before the new location, then */ 1207 /* decrement the new location, so that it gets put */ 1208 /* into the right spot. */ 1209 1210 if ((n->parent == tn) && (n->index < idx)) { 1211 idx --; 1212 } 1213 1214 tn_detach (n); 1215 tn_insert (tn, idx, n); 1216 idx++; 1217 } 1218 } 1219 1220 Tcl_SetObjResult (interp, Tcl_NewListObj (objc-4,objv+4)); 1221 1222 } else { 1223 /* Create a single new node with a generated name, */ 1224 /* then insert it. */ 1225 1226 CONST char* name = t_newnodename (t); 1227 TN* nn = tn_new (t, name); 1228 1229 tn_insert (tn, idx, nn); 1230 Tcl_SetObjResult (interp, Tcl_NewListObj (1, &nn->name)); 1231 } 1232 1233 return TCL_OK; 1234} 1235 1236/* 1237 *--------------------------------------------------------------------------- 1238 * 1239 * tm_ISLEAF -- 1240 * 1241 * Returns a boolean value signaling whether the given node is a leaf or 1242 * not. True implies that the node is a leaf. 1243 * 1244 * Results: 1245 * A standard Tcl result code. 1246 * 1247 * Side effects: 1248 * May release and allocate memory. 1249 * 1250 *--------------------------------------------------------------------------- 1251 */ 1252 1253int 1254tm_ISLEAF (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1255{ 1256 /* Syntax: tree isleaf node 1257 * [0] [1] [2] 1258 */ 1259 1260 TN* tn; 1261 Tcl_Obj* res; 1262 1263 if (objc != 3) { 1264 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1265 return TCL_ERROR; 1266 } 1267 1268 tn = tn_get_node (t, objv [2], interp, objv [0]); 1269 if (tn == NULL) { 1270 return TCL_ERROR; 1271 } 1272 1273 Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->nchildren == 0)); 1274 return TCL_OK; 1275} 1276 1277/* 1278 *--------------------------------------------------------------------------- 1279 * 1280 * tm_KEYEXISTS -- 1281 * 1282 * Returns a boolean value signaling whether the given node has the 1283 * named attribute or not. True implies that the attribute exists. 1284 * 1285 * Results: 1286 * A standard Tcl result code. 1287 * 1288 * Side effects: 1289 * May release and allocate memory. 1290 * 1291 *--------------------------------------------------------------------------- 1292 */ 1293 1294int 1295tm_KEYEXISTS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1296{ 1297 /* Syntax: tree keyexists node [key] 1298 * [0] [1] [2] [3] 1299 */ 1300 1301 TN* tn; 1302 Tcl_HashEntry* he; 1303 CONST char* key; 1304 1305 if (objc != 4) { 1306 Tcl_WrongNumArgs (interp, 2, objv, "node key"); 1307 return TCL_ERROR; 1308 } 1309 1310 tn = tn_get_node (t, objv [2], interp, objv [0]); 1311 if (tn == NULL) { 1312 return TCL_ERROR; 1313 } 1314 1315 key = Tcl_GetString (objv [3]); 1316 1317 if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) { 1318 Tcl_SetObjResult (interp, Tcl_NewIntObj (0)); 1319 return TCL_OK; 1320 } 1321 1322 he = Tcl_FindHashEntry (tn->attr, key); 1323 1324 Tcl_SetObjResult (interp, Tcl_NewIntObj (he != NULL)); 1325 return TCL_OK; 1326} 1327 1328/* 1329 *--------------------------------------------------------------------------- 1330 * 1331 * tm_KEYS -- 1332 * 1333 * Returns a list containing all attribute names matching the pattern 1334 * for the attributes of the specified node. 1335 * 1336 * Results: 1337 * A standard Tcl result code. 1338 * 1339 * Side effects: 1340 * May release and allocate memory. 1341 * 1342 *--------------------------------------------------------------------------- 1343 */ 1344 1345int 1346tm_KEYS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1347{ 1348 /* Syntax: tree keys node ?pattern? 1349 * [0] [1] [2] [3] 1350 */ 1351 1352 TN* tn; 1353 Tcl_HashEntry* he; 1354 Tcl_HashSearch hs; 1355 CONST char* key; 1356 int i; 1357 int listc; 1358 Tcl_Obj** listv; 1359 CONST char* pattern; 1360 int matchall = 0; 1361 1362 if ((objc != 3) && (objc != 4)) { 1363 Tcl_WrongNumArgs (interp, 2, objv, "node ?pattern?"); 1364 return TCL_ERROR; 1365 } 1366 1367 tn = tn_get_node (t, objv [2], interp, objv [0]); 1368 if (tn == NULL) { 1369 return TCL_ERROR; 1370 } 1371 1372 if ((tn->attr == NULL) || (tn->attr->numEntries == 0)) { 1373 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 1374 return TCL_OK; 1375 } 1376 1377 listc = tn->attr->numEntries; 1378 listv = NALLOC (listc, Tcl_Obj*); 1379 1380 if (objc == 4) { 1381 pattern = Tcl_GetString(objv[3]); 1382 matchall = (strcmp (pattern, "*") == 0); 1383 } 1384 1385 if ((objc == 3) || matchall) { 1386 /* Unpatterned retrieval, or pattern '*' */ 1387 1388 for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); 1389 he != NULL; 1390 he = Tcl_NextHashEntry(&hs)) { 1391 1392 ASSERT_BOUNDS (i, listc); 1393 listv [i++] = Tcl_NewStringObj (Tcl_GetHashKey (tn->attr, he), -1); 1394 } 1395 1396 ASSERT (i == listc, "Bad key retrieval"); 1397 1398 } else { 1399 /* Filtered retrieval, glob pattern */ 1400 1401 for (i = 0, he = Tcl_FirstHashEntry(tn->attr, &hs); 1402 he != NULL; 1403 he = Tcl_NextHashEntry(&hs)) { 1404 1405 key = Tcl_GetHashKey (tn->attr, he); 1406 if (Tcl_StringMatch(key, pattern)) { 1407 ASSERT_BOUNDS (i, listc); 1408 1409 listv [i++] = Tcl_NewStringObj (key, -1); 1410 } 1411 } 1412 1413 ASSERT (i <= listc, "Bad key glob retrieval"); 1414 listc = i; 1415 } 1416 1417 if (listc) { 1418 Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); 1419 } else { 1420 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 1421 } 1422 1423 ckfree ((char*) listv); 1424 return TCL_OK; 1425} 1426 1427/* 1428 *--------------------------------------------------------------------------- 1429 * 1430 * tm_LAPPEND -- 1431 * 1432 * Appends a value as list element to an attribute of the named node. 1433 * May create the attribute. 1434 * 1435 * Results: 1436 * A standard Tcl result code. 1437 * 1438 * Side effects: 1439 * May release and allocate memory. 1440 * 1441 *--------------------------------------------------------------------------- 1442 */ 1443 1444int 1445tm_LAPPEND (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1446{ 1447 /* Syntax: tree lappend node key value 1448 * [0] [1] [2] [3] [4] 1449 */ 1450 1451 TN* tn; 1452 Tcl_HashEntry* he; 1453 CONST char* key; 1454 Tcl_Obj* av; 1455 1456 if (objc != 5) { 1457 Tcl_WrongNumArgs (interp, 2, objv, "node key value"); 1458 return TCL_ERROR; 1459 } 1460 1461 tn = tn_get_node (t, objv [2], interp, objv [0]); 1462 if (tn == NULL) { 1463 return TCL_ERROR; 1464 } 1465 1466 key = Tcl_GetString (objv [3]); 1467 1468 tn_extend_attr (tn); 1469 1470 he = Tcl_FindHashEntry (tn->attr, key); 1471 1472 if (he == NULL) { 1473 int new; 1474 he = Tcl_CreateHashEntry(tn->attr, key, &new); 1475 1476 av = Tcl_NewListObj (0,NULL); 1477 Tcl_IncrRefCount (av); 1478 Tcl_SetHashValue (he, (ClientData) av); 1479 1480 } else { 1481 av = (Tcl_Obj*) Tcl_GetHashValue(he); 1482 1483 if (Tcl_IsShared (av)) { 1484 Tcl_DecrRefCount (av); 1485 av = Tcl_DuplicateObj (av); 1486 Tcl_IncrRefCount (av); 1487 1488 Tcl_SetHashValue (he, (ClientData) av); 1489 } 1490 } 1491 1492 Tcl_ListObjAppendElement (interp, av, objv [4]); 1493 1494 Tcl_SetObjResult (interp, av); 1495 return TCL_OK; 1496} 1497 1498/* 1499 *--------------------------------------------------------------------------- 1500 * 1501 * tm_LEAVES -- 1502 * 1503 * Returns a list containing all leaf nodes of the tree. 1504 * 1505 * Results: 1506 * A standard Tcl result code. 1507 * 1508 * Side effects: 1509 * May release and allocate memory. 1510 * 1511 *--------------------------------------------------------------------------- 1512 */ 1513 1514int 1515tm_LEAVES (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1516{ 1517 /* Syntax: tree leaves 1518 * [0] [1] 1519 */ 1520 1521 TN* tn; 1522 int listc; 1523 1524 if (objc != 2) { 1525 Tcl_WrongNumArgs (interp, 2, objv, NULL); 1526 return TCL_ERROR; 1527 } 1528 1529 listc = t->nleaves; 1530 1531 if (listc) { 1532 int i; 1533 Tcl_Obj** listv = NALLOC (listc, Tcl_Obj*); 1534 TN* iter; 1535 1536 for (i = 0, iter = t->leaves; 1537 iter != NULL; 1538 iter = iter->nextleaf, i++) { 1539 1540 ASSERT_BOUNDS (i, listc); 1541 listv [i] = iter->name; 1542 } 1543 1544 ASSERT (i == listc, "Bad list of leaves"); 1545 1546 Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); 1547 ckfree ((char*) listv); 1548 } else { 1549 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 1550 } 1551 return TCL_OK; 1552} 1553 1554/* 1555 *--------------------------------------------------------------------------- 1556 * 1557 * tm_MOVE -- 1558 * 1559 * Moves the specified node to a (new) parent. 1560 * 1561 * Results: 1562 * A standard Tcl result code. 1563 * 1564 * Side effects: 1565 * May release and allocate memory. 1566 * 1567 *--------------------------------------------------------------------------- 1568 */ 1569 1570int 1571tm_MOVE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1572{ 1573 /* Syntax: tree move parent index node ?node...? 1574 * [0] [1] [2] [3] [4] [5+] 1575 */ 1576 1577 TN* tn; 1578 int idx; 1579 TN* n; 1580 int listc; 1581 TN** listv; 1582 int i; 1583 1584 if (objc < 5) { 1585 Tcl_WrongNumArgs (interp, 2, objv, "parentNode index node ?node...?"); 1586 return TCL_ERROR; 1587 } 1588 1589 Tcl_AppendResult (interp, "parent ", NULL); 1590 tn = tn_get_node (t, objv [2], interp, objv [0]); 1591 if (tn == NULL) { 1592 return TCL_ERROR; 1593 } 1594 Tcl_ResetResult (interp); 1595 1596 if (TclGetIntForIndex (interp, objv [3], tn->nchildren, &idx) != TCL_OK) { 1597 return TCL_ERROR; 1598 } 1599 1600 /* Validate all nodes to move before trying to rearrange 1601 * tree in any way. */ 1602 1603 listc = objc-4; 1604 listv = NALLOC (listc, TN*); 1605 1606 for (i=4; i < objc; i++) { 1607 ASSERT_BOUNDS (i, objc); 1608 ASSERT_BOUNDS (i-4, listc); 1609 1610 n = tn_get_node (t, objv [i], interp, objv [0]); 1611 listv [i-4] = n; 1612 1613 if (n == NULL) { 1614 /* Node not found, immovable */ 1615 ckfree ((char*) listv); 1616 return TCL_ERROR; 1617 1618 } else if (n == t->root) { 1619 /* Node found, is root, immovable */ 1620 1621 Tcl_AppendResult (interp, "cannot move root node", NULL); 1622 ckfree ((char*) listv); 1623 return TCL_ERROR; 1624 1625 } else if ((n == tn) || tn_isancestorof (n, tn)) { 1626 /* Node found, not root, but move is irregular */ 1627 1628 /* The chosen parent is actually a descendant of the */ 1629 /* node to move. The move would create a circle. This */ 1630 /* is not allowed. */ 1631 1632 Tcl_Obj* err = Tcl_NewObj (); 1633 1634 Tcl_AppendToObj (err, "node \"", -1); 1635 Tcl_AppendObjToObj (err, objv [i]); 1636 Tcl_AppendToObj (err, "\" cannot be its own descendant", -1); 1637 1638 Tcl_SetObjResult (interp, err); 1639 ckfree ((char*) listv); 1640 return TCL_ERROR; 1641 } 1642 } 1643 1644 for (i=0; i < listc; i++) { 1645 ASSERT_BOUNDS (i, listc); 1646 tn_detach (listv [i]); 1647 } 1648 1649 tn_insertmany (tn, idx, listc, listv); 1650 1651 ckfree ((char*) listv); 1652 return TCL_OK; 1653} 1654 1655/* 1656 *--------------------------------------------------------------------------- 1657 * 1658 * tm_NEXT -- 1659 * 1660 * Returns the name of node which is the right sibling of the given node. 1661 * The empty string is delivered if the node has no right sibling. 1662 * 1663 * Results: 1664 * A standard Tcl result code. 1665 * 1666 * Side effects: 1667 * May release and allocate memory. 1668 * 1669 *--------------------------------------------------------------------------- 1670 */ 1671 1672int 1673tm_NEXT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1674{ 1675 /* Syntax: tree next node 1676 * [0] [1] [2] 1677 */ 1678 1679 TN* tn; 1680 Tcl_Obj* res; 1681 1682 if (objc != 3) { 1683 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1684 return TCL_ERROR; 1685 } 1686 1687 tn = tn_get_node (t, objv [2], interp, objv [0]); 1688 if (tn == NULL) { 1689 return TCL_ERROR; 1690 } 1691 1692 if ((tn->parent == NULL) || 1693 (tn->right == NULL)) { 1694 Tcl_SetObjResult (interp, Tcl_NewObj ()); 1695 } else { 1696 Tcl_SetObjResult (interp, tn->right->name); 1697 } 1698 return TCL_OK; 1699} 1700 1701/* 1702 *--------------------------------------------------------------------------- 1703 * 1704 * tm_NODES -- 1705 * 1706 * Returns a list containing all nodes of the tree. 1707 * 1708 * Results: 1709 * A standard Tcl result code. 1710 * 1711 * Side effects: 1712 * May release and allocate memory. 1713 * 1714 *--------------------------------------------------------------------------- 1715 */ 1716 1717int 1718tm_NODES (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1719{ 1720 /* Syntax: tree nodes 1721 * [0] [1] 1722 */ 1723 1724 TN* tn; 1725 int listc; 1726 1727 if (objc != 2) { 1728 Tcl_WrongNumArgs (interp, 2, objv, NULL); 1729 return TCL_ERROR; 1730 } 1731 1732 listc = t->nnodes; 1733 if (listc) { 1734 int i; 1735 Tcl_Obj** listv = NALLOC (listc, Tcl_Obj*); 1736 TN* iter; 1737 1738 for (i = 0, iter = t->nodes; 1739 iter != NULL; 1740 iter = iter->nextnode, i++) { 1741 1742 ASSERT_BOUNDS (i, listc); 1743 listv [i] = iter->name; 1744 } 1745 1746 ASSERT (i == listc, "Bad list of nodes"); 1747 1748 Tcl_SetObjResult (interp, Tcl_NewListObj (listc, listv)); 1749 ckfree ((char*) listv); 1750 } else { 1751 Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); 1752 } 1753 return TCL_OK; 1754} 1755 1756/* 1757 *--------------------------------------------------------------------------- 1758 * 1759 * tm_NUMCHILDREN -- 1760 * 1761 * Returns a non-negative integer number, the number of direct children 1762 * of the specified node. Zero children implies that the node is a leaf. 1763 * 1764 * Results: 1765 * A standard Tcl result code. 1766 * 1767 * Side effects: 1768 * May release and allocate memory. 1769 * 1770 *--------------------------------------------------------------------------- 1771 */ 1772 1773int 1774tm_NUMCHILDREN (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1775{ 1776 /* Syntax: tree numchildren node 1777 * [0] [1] [2] 1778 */ 1779 1780 TN* tn; 1781 1782 if (objc != 3) { 1783 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1784 return TCL_ERROR; 1785 } 1786 1787 tn = tn_get_node (t, objv [2], interp, objv [0]); 1788 if (tn == NULL) { 1789 return TCL_ERROR; 1790 } 1791 1792 Tcl_SetObjResult (interp, Tcl_NewIntObj (tn->nchildren)); 1793 return TCL_OK; 1794} 1795 1796/* 1797 *--------------------------------------------------------------------------- 1798 * 1799 * tm_PARENT -- 1800 * 1801 * Returns the name of the parent node for the specified node. Delivers 1802 * an empty string if the node is the root of the tree. 1803 * 1804 * Results: 1805 * A standard Tcl result code. 1806 * 1807 * Side effects: 1808 * May release and allocate memory. 1809 * 1810 *--------------------------------------------------------------------------- 1811 */ 1812 1813int 1814tm_PARENT (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1815{ 1816 /* Syntax: tree parent node 1817 * [0] [1] [2] 1818 */ 1819 1820 TN* tn; 1821 1822 if (objc != 3) { 1823 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1824 return TCL_ERROR; 1825 } 1826 1827 tn = tn_get_node (t, objv [2], interp, objv [0]); 1828 if (tn == NULL) { 1829 return TCL_ERROR; 1830 } 1831 1832 if (tn->parent == NULL) { 1833 Tcl_SetObjResult (interp, Tcl_NewObj ()); 1834 } else { 1835 Tcl_SetObjResult (interp, tn->parent->name); 1836 } 1837 return TCL_OK; 1838} 1839 1840/* 1841 *--------------------------------------------------------------------------- 1842 * 1843 * tm_PREVIOUS -- 1844 * 1845 * Returns the name of node which is the left sibling of the given node. 1846 * The empty string is delivered if the node has no left sibling. 1847 * 1848 * Results: 1849 * A standard Tcl result code. 1850 * 1851 * Side effects: 1852 * May release and allocate memory. 1853 * 1854 *--------------------------------------------------------------------------- 1855 */ 1856 1857int 1858tm_PREVIOUS (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1859{ 1860 /* Syntax: tree previous node 1861 * [0] [1] [2] 1862 */ 1863 1864 TN* tn; 1865 1866 if (objc != 3) { 1867 Tcl_WrongNumArgs (interp, 2, objv, "node"); 1868 return TCL_ERROR; 1869 } 1870 1871 tn = tn_get_node (t, objv [2], interp, objv [0]); 1872 if (tn == NULL) { 1873 return TCL_ERROR; 1874 } 1875 1876 if ((tn->parent == NULL) || 1877 (tn->left == NULL)) { 1878 Tcl_SetObjResult (interp, Tcl_NewObj ()); 1879 } else { 1880 Tcl_SetObjResult (interp, tn->left->name); 1881 } 1882 return TCL_OK; 1883} 1884 1885/* 1886 *--------------------------------------------------------------------------- 1887 * 1888 * tm_RENAME -- 1889 * 1890 * Gives the specified node a new name. 1891 * 1892 * Results: 1893 * A standard Tcl result code. 1894 * 1895 * Side effects: 1896 * May release and allocate memory. 1897 * 1898 *--------------------------------------------------------------------------- 1899 */ 1900 1901int 1902tm_RENAME (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1903{ 1904 /* Syntax: tree rename node newname 1905 * [0] [1] [2] [3] 1906 */ 1907 1908 TN* tn; 1909 TN* new; 1910 Tcl_Obj* res; 1911 int nnew; 1912 1913 if (objc != 4) { 1914 Tcl_WrongNumArgs (interp, 2, objv, "node newname"); 1915 return TCL_ERROR; 1916 } 1917 1918 tn = tn_get_node (t, objv [2], interp, objv [0]); 1919 if (tn == NULL) { 1920 return TCL_ERROR; 1921 } 1922 1923 new = tn_get_node (t, objv [3], NULL, NULL); 1924 if (new != NULL) { 1925 Tcl_Obj* err = Tcl_NewObj (); 1926 1927 Tcl_AppendToObj (err, "unable to rename node to \"", -1); 1928 Tcl_AppendObjToObj (err, objv [3]); 1929 Tcl_AppendToObj (err, "\", node of that name already present in the tree \"", -1); 1930 Tcl_AppendObjToObj (err, objv [0]); 1931 Tcl_AppendToObj (err, "\"", -1); 1932 1933 Tcl_SetObjResult (interp, err); 1934 return TCL_ERROR; 1935 } 1936 1937 /* Release current name, ... */ 1938 Tcl_DecrRefCount (tn->name); 1939 1940 /* ... and create a new one, by taking the argument 1941 * and shimmering it */ 1942 1943 tn->name = objv [3]; 1944 Tcl_IncrRefCount (tn->name); 1945 tn_shimmer (tn->name, tn); 1946 1947 /* Update the global name mapping as well */ 1948 1949 Tcl_DeleteHashEntry (tn->he); 1950 tn->he = Tcl_CreateHashEntry(&t->node, Tcl_GetString (tn->name), &nnew); 1951 Tcl_SetHashValue (tn->he, (ClientData) tn); 1952 1953 Tcl_SetObjResult (interp, objv [3]); 1954 return TCL_OK; 1955} 1956 1957/* 1958 *--------------------------------------------------------------------------- 1959 * 1960 * tm_ROOTNAME -- 1961 * 1962 * Returns the name of the root node. 1963 * 1964 * Results: 1965 * A standard Tcl result code. 1966 * 1967 * Side effects: 1968 * May release and allocate memory. 1969 * 1970 *--------------------------------------------------------------------------- 1971 */ 1972 1973int 1974tm_ROOTNAME (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 1975{ 1976 /* Syntax: tree rootname 1977 * [0] [1] 1978 */ 1979 1980 TN* tn; 1981 1982 if (objc != 2) { 1983 Tcl_WrongNumArgs (interp, 2, objv, NULL); 1984 return TCL_ERROR; 1985 } 1986 1987 Tcl_SetObjResult (interp, t->root->name); 1988 return TCL_OK; 1989} 1990 1991/* 1992 *--------------------------------------------------------------------------- 1993 * 1994 * tm_SERIALIZE -- 1995 * 1996 * Returns a Tcl value serializing the tree from the optional named node 1997 * on downward. 1998 * 1999 * Results: 2000 * A standard Tcl result code. 2001 * 2002 * Side effects: 2003 * May release and allocate memory. 2004 * 2005 *--------------------------------------------------------------------------- 2006 */ 2007 2008int 2009tm_SERIALIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2010{ 2011 /* Syntax: tree serialize ?node? 2012 * [0] [1] [2] 2013 */ 2014 2015 TN* tn; 2016 2017 if ((objc != 2) && (objc != 3)) { 2018 Tcl_WrongNumArgs (interp, 2, objv, "?node?"); 2019 return TCL_ERROR; 2020 } 2021 2022 if (objc == 2) { 2023 tn = t->root; 2024 } else { 2025 tn = tn_get_node (t, objv [2], interp, objv [0]); 2026 if (tn == NULL) { 2027 return TCL_ERROR; 2028 } 2029 } 2030 2031 Tcl_SetObjResult (interp, tms_serialize (tn)); 2032 return TCL_OK; 2033} 2034 2035/* 2036 *--------------------------------------------------------------------------- 2037 * 2038 * tm_SET -- 2039 * 2040 * Adds an attribute and its value to a named node. May replace an 2041 * existing value. 2042 * 2043 * Results: 2044 * A standard Tcl result code. 2045 * 2046 * Side effects: 2047 * May release and allocate memory. 2048 * 2049 *--------------------------------------------------------------------------- 2050 */ 2051 2052int 2053tm_SET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2054{ 2055 /* Syntax: tree set node key ?value? 2056 * [0] [1] [2] [3] [4] 2057 */ 2058 2059 TN* tn; 2060 Tcl_HashEntry* he; 2061 CONST char* key; 2062 2063 if (objc == 4) { 2064 return tm_GET (t, interp, objc, objv); 2065 } 2066 if (objc != 5) { 2067 Tcl_WrongNumArgs (interp, 2, objv, "node key ?value?"); 2068 return TCL_ERROR; 2069 } 2070 2071 tn = tn_get_node (t, objv [2], interp, objv [0]); 2072 if (tn == NULL) { 2073 return TCL_ERROR; 2074 } 2075 2076 key = Tcl_GetString (objv [3]); 2077 2078 tn_extend_attr (tn); 2079 2080 he = Tcl_FindHashEntry (tn->attr, key); 2081 2082 if (he == NULL) { 2083 int new; 2084 he = Tcl_CreateHashEntry(tn->attr, key, &new); 2085 } else { 2086 Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); 2087 } 2088 2089 Tcl_IncrRefCount (objv [4]); 2090 Tcl_SetHashValue (he, (ClientData) objv [4]); 2091 2092 Tcl_SetObjResult (interp, objv [4]); 2093 return TCL_OK; 2094} 2095 2096/* 2097 *--------------------------------------------------------------------------- 2098 * 2099 * tm_SIZE -- 2100 * 2101 * Returns the number of descendants of a named optional node. Defaults 2102 * to #descendants of root. 2103 * 2104 * Results: 2105 * A standard Tcl result code. 2106 * 2107 * Side effects: 2108 * None. 2109 * 2110 *--------------------------------------------------------------------------- 2111 */ 2112 2113int 2114tm_SIZE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2115{ 2116 /* Syntax: tree size ?node? 2117 * [0] [1] [2] 2118 */ 2119 2120 int n; 2121 2122 if ((objc != 2) && (objc != 3)) { 2123 Tcl_WrongNumArgs (interp, 2, objv, "?node?"); 2124 return TCL_ERROR; 2125 } 2126 2127 if (objc == 2) { 2128 /* Descendants of root. Cheap. Is size of */ 2129 /* tree minus root. No need to compute full */ 2130 /* structural information. */ 2131 2132 n = t->nnodes - 1; 2133 } else { 2134 TN* tn; 2135 2136 tn = tn_get_node (t, objv [2], interp, objv [0]); 2137 if (tn == NULL) { 2138 return TCL_ERROR; 2139 } 2140 2141 n = tn_ndescendants (tn); 2142 } 2143 2144 Tcl_SetObjResult (interp, Tcl_NewIntObj (n)); 2145 return TCL_OK; 2146} 2147 2148/* 2149 *--------------------------------------------------------------------------- 2150 * 2151 * tm_SPLICE -- 2152 * 2153 * Replaces a series of nodes in a parent with o new node, and makes the 2154 * replaced nodes the children of the new one. Complementary to tm_CUT. 2155 * 2156 * Results: 2157 * A standard Tcl result code. 2158 * 2159 * Side effects: 2160 * Changes internal pointering of nodes. 2161 * 2162 *--------------------------------------------------------------------------- 2163 */ 2164 2165int 2166tm_SPLICE (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2167{ 2168 /* Syntax: tree splice parent from ?to ?node?? 2169 * [0] [1] [2] [3] [4] [5] 2170 */ 2171 2172 TN* p; 2173 TN* new; 2174 int from, to, i; 2175 int nc; 2176 TN** nv; 2177 CONST char* name; 2178 2179 if ((objc < 4) || (objc > 6)) { 2180 Tcl_WrongNumArgs (interp, 2, objv, "parent from ?to ?node??"); 2181 return TCL_ERROR; 2182 } 2183 2184 p = tn_get_node (t, objv [2], interp, objv [0]); 2185 if (p == NULL) { 2186 return TCL_ERROR; 2187 } 2188 2189 if (TclGetIntForIndex (interp, objv [3], p->nchildren - 1, &from) != TCL_OK) { 2190 return TCL_ERROR; 2191 } 2192 2193 if (objc > 4) { 2194 if (TclGetIntForIndex (interp, objv [4], p->nchildren - 1, &to) != TCL_OK) { 2195 return TCL_ERROR; 2196 } 2197 } else { 2198 to = p->nchildren - 1; 2199 } 2200 2201 if (from < 0) {from = 0;} 2202 if (to >= p->nchildren) {to = p->nchildren - 1;} 2203 2204 if (objc > 5) { 2205 new = tn_get_node (t, objv [5], NULL, NULL); 2206 if (new != NULL) { 2207 /* Already present, fail */ 2208 Tcl_Obj* err = Tcl_NewObj (); 2209 2210 Tcl_AppendToObj (err, "node \"", -1); 2211 Tcl_AppendObjToObj (err, objv [5]); 2212 Tcl_AppendToObj (err, "\" already exists in tree \"", -1); 2213 Tcl_AppendObjToObj (err, objv [0]); 2214 Tcl_AppendToObj (err, "\"", -1); 2215 2216 Tcl_SetObjResult (interp, err); 2217 return TCL_ERROR; 2218 } 2219 2220 name = Tcl_GetString (objv [5]); 2221 } else { 2222 name = t_newnodename (t); 2223 } 2224 2225 new = tn_new (t, name); 2226 2227 /* Move the chosen children to the new node. */ 2228 /* Then insert the new node in their place. */ 2229 2230 nc = to-from+1; 2231 2232 if (nc > 0) { 2233 nv = tn_detachmany (p->child [from], nc); 2234 tn_appendmany (new, nc, nv); 2235 ckfree ((char*) nv); 2236 } 2237 2238 tn_insert (p, from, new); 2239 2240 Tcl_SetObjResult (interp, new->name); 2241 return TCL_OK; 2242} 2243 2244/* 2245 *--------------------------------------------------------------------------- 2246 * 2247 * tm_SWAP -- 2248 * 2249 * Swap the names of two nodes. 2250 * 2251 * Results: 2252 * A standard Tcl result code. 2253 * 2254 * Side effects: 2255 * None. 2256 * 2257 *--------------------------------------------------------------------------- 2258 */ 2259 2260int 2261tm_SWAP (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2262{ 2263 /* Syntax: tree swap a b 2264 * [0] [1] [2] [3] 2265 */ 2266 2267 TN* tna; 2268 TN* tnb; 2269 CONST char* key; 2270 2271 if (objc != 4) { 2272 Tcl_WrongNumArgs (interp, 2, objv, "nodea nodeb"); 2273 return TCL_ERROR; 2274 } 2275 2276 tna = tn_get_node (t, objv [2], interp, objv [0]); 2277 if (tna == NULL) { 2278 return TCL_ERROR; 2279 } 2280 if (tna == t->root) { 2281 Tcl_AppendResult (interp, "cannot swap root node", NULL); 2282 return TCL_ERROR; 2283 } 2284 2285 tnb = tn_get_node (t, objv [3], interp, objv [0]); 2286 if (tnb == NULL) { 2287 return TCL_ERROR; 2288 } 2289 if (tnb == t->root) { 2290 Tcl_AppendResult (interp, "cannot swap root node", NULL); 2291 return TCL_ERROR; 2292 } 2293 2294 if (tna == tnb) { 2295 Tcl_Obj* err = Tcl_NewObj (); 2296 2297 Tcl_AppendToObj (err, "cannot swap node \"", -1); 2298 Tcl_AppendObjToObj (err, objv [2]); 2299 Tcl_AppendToObj (err, "\" with itself", -1); 2300 2301 Tcl_SetObjResult (interp, err); 2302 return TCL_ERROR; 2303 } 2304 2305 { 2306#define SWAP(a,b,t) t = a; a = b ; b = t 2307#define SWAPS(x,t) SWAP(tna->x,tnb->x,t) 2308 2309 /* The two nodes flip all structural information around to trade places */ 2310 /* It might actually be easier to flip the non-structural data */ 2311 /* name, he, attr, data in the node map */ 2312 2313 Tcl_Obj* to; 2314 Tcl_HashTable* ta; 2315 Tcl_HashEntry* th; 2316 2317 SWAPS (name, to); 2318 SWAPS (attr, ta); 2319 SWAPS (he, th); 2320 2321 Tcl_SetHashValue (tna->he, (ClientData) tna); 2322 Tcl_SetHashValue (tnb->he, (ClientData) tnb); 2323 } 2324 2325 tna->tree->structure = 0; 2326 return TCL_OK; 2327} 2328 2329/* 2330 *--------------------------------------------------------------------------- 2331 * 2332 * tm_UNSET -- 2333 * 2334 * Removes an attribute and its value from a named node. 2335 * 2336 * Results: 2337 * A standard Tcl result code. 2338 * 2339 * Side effects: 2340 * May release memory. 2341 * 2342 *--------------------------------------------------------------------------- 2343 */ 2344 2345int 2346tm_UNSET (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2347{ 2348 /* Syntax: tree unset node key 2349 * [0] [1] [2] [3] 2350 */ 2351 2352 TN* tn; 2353 Tcl_HashEntry* he; 2354 CONST char* key; 2355 2356 if (objc != 4) { 2357 Tcl_WrongNumArgs (interp, 2, objv, "node key"); 2358 return TCL_ERROR; 2359 } 2360 2361 tn = tn_get_node (t, objv [2], interp, objv [0]); 2362 if (tn == NULL) { 2363 return TCL_ERROR; 2364 } 2365 2366 key = Tcl_GetString (objv [3]); 2367 2368 if (tn->attr) { 2369 he = Tcl_FindHashEntry (tn->attr, key); 2370 2371 if (he != NULL) { 2372 Tcl_DecrRefCount ((Tcl_Obj*) Tcl_GetHashValue(he)); 2373 Tcl_DeleteHashEntry (he); 2374 } 2375 } 2376 return TCL_OK; 2377} 2378 2379/* 2380 *--------------------------------------------------------------------------- 2381 * 2382 * tm_WALK -- 2383 * 2384 * Walks over the tree as per the options and invokes a Tcl script per 2385 * node. 2386 * 2387 * Results: 2388 * A standard Tcl result code. 2389 * 2390 * Side effects: 2391 * Per the Tcl procedure invoked by the method. 2392 * 2393 *--------------------------------------------------------------------------- 2394 */ 2395 2396int 2397tm_WALK (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2398{ 2399 int type, order, rem, res; 2400 Tcl_Obj* avarname; 2401 Tcl_Obj* nvarname; 2402 int lvc; 2403 Tcl_Obj** lvv; 2404 TN* tn; 2405 2406#undef USAGE 2407#define USAGE "node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script" 2408 2409 /* Syntax: tree walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script 2410 * [0] [1] [2] [3] [4] [5] [6] [7] [8] [9] 2411 * 2412 * Syntax: tree walk node loopvar script 2413 * [0] [1] [2] [3] [4] 2414 */ 2415 2416 if ((objc < 5) || (objc > 10)) { 2417 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 2418 return TCL_ERROR; 2419 } 2420 2421 tn = tn_get_node (t, objv [2], interp, objv [0]); 2422 if (tn == NULL) { 2423 return TCL_ERROR; 2424 } 2425 2426 if (t_walkoptions (interp, 2, objc, objv, 2427 &type, &order, &rem, USAGE) != TCL_OK) { 2428 return TCL_ERROR; 2429 } 2430 2431 /* Remainder is 'loopvars script' */ 2432 2433 if (Tcl_ListObjGetElements (interp, objv [rem], &lvc, &lvv) != TCL_OK) { 2434 return TCL_ERROR; 2435 } 2436 if (lvc > 2) { 2437 Tcl_AppendResult (interp, 2438 "too many loop variables, at most two allowed", 2439 NULL); 2440 return TCL_ERROR; 2441 } else if (lvc == 2) { 2442 avarname = lvv [0]; 2443 nvarname = lvv [1]; 2444 2445 Tcl_IncrRefCount (avarname); 2446 Tcl_IncrRefCount (nvarname); 2447 } else { 2448 avarname = NULL; 2449 nvarname = lvv [0]; 2450 2451 Tcl_IncrRefCount (nvarname); 2452 } 2453 2454 if (!strlen (Tcl_GetString (objv [rem+1]))) { 2455 Tcl_AppendResult (interp, 2456 "no script specified, or empty", 2457 NULL); 2458 return TCL_ERROR; 2459 } 2460 2461 res = t_walk (interp, tn, type, order, 2462 t_walk_invokescript, 2463 objv [rem+1], avarname, nvarname); 2464 2465 if (avarname) { 2466 Tcl_IncrRefCount (avarname); 2467 } 2468 if (nvarname) { 2469 Tcl_IncrRefCount (nvarname); 2470 } 2471 return res; 2472} 2473 2474/* 2475 *--------------------------------------------------------------------------- 2476 * 2477 * tm_WALKPROC -- 2478 * 2479 * Walks over the tree as per the options and invokes a named Tcl command 2480 * prefix per node. 2481 * 2482 * Results: 2483 * A standard Tcl result code. 2484 * 2485 * Side effects: 2486 * Per the Tcl procedure invoked by the method. 2487 * 2488 *--------------------------------------------------------------------------- 2489 */ 2490 2491int 2492tm_WALKPROC (T* t, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 2493{ 2494 int type, order, rem, i, res; 2495 TN* tn; 2496 int cc; 2497 Tcl_Obj** cv; 2498 int ec; 2499 Tcl_Obj** ev; 2500 2501 /* Syntax: tree walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix 2502 * [0] [1] [2] [3] [4] [5] [6] [7] [8] 2503 * 2504 * Syntax: tree walk node cmdprefix 2505 * [0] [1] [2] [3] 2506 */ 2507 2508#undef USAGE 2509#define USAGE "node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix" 2510 2511 if ((objc < 4) || (objc > 9)) { 2512 Tcl_WrongNumArgs (interp, 2, objv, USAGE); 2513 return TCL_ERROR; 2514 } 2515 2516 tn = tn_get_node (t, objv [2], interp, objv [0]); 2517 if (tn == NULL) { 2518 return TCL_ERROR; 2519 } 2520 2521 if (t_walkoptions (interp, 1, objc, objv, 2522 &type, &order, &rem, USAGE) != TCL_OK) { 2523 return TCL_ERROR; 2524 } 2525 2526 /* Remainder is 'cmd' */ 2527 2528 if (!strlen (Tcl_GetString (objv [rem]))) { 2529 Tcl_AppendResult (interp, 2530 "no script specified, or empty", 2531 NULL); 2532 return TCL_ERROR; 2533 } 2534 if (Tcl_ListObjGetElements (interp, objv [rem], &cc, &cv) != TCL_OK) { 2535 return TCL_ERROR; 2536 } 2537 2538 ec = cc + 3; 2539 ev = NALLOC (ec, Tcl_Obj*); 2540 2541 for (i = 0; i < cc; i++) { 2542 ev [i] = cv [i]; 2543 Tcl_IncrRefCount (ev [i]); 2544 } 2545 2546 res = t_walk (interp, tn, type, order, 2547 t_walk_invokecmd, 2548 (Tcl_Obj*) cc, (Tcl_Obj*) ev, objv [0]); 2549 2550 ckfree ((char*) ev); 2551 return res; 2552} 2553 2554/* .................................................. */ 2555/* .................................................. */ 2556 2557/* 2558 * Handling of all indices, numeric and 'end-x' forms. Copied straight out of 2559 * the Tcl core as this is not exported through the public API. 2560 * 2561 * I.e. a full copy of TclGetIntForIndex, its Tcl_ObjType, and of several 2562 * supporting functions and macros internal to the core. :( 2563 * 2564 * To avoid clashing with the object type in the core the object type here has 2565 * been given a different name. 2566 */ 2567 2568#define UCHAR(c) ((unsigned char) (c)) 2569 2570static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); 2571static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, 2572 Tcl_Obj* objPtr)); 2573 2574Tcl_ObjType EndOffsetType = { 2575 "tcllib/struct::tree/end-offset", /* name */ 2576 (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ 2577 (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ 2578 UpdateStringOfEndOffset, /* updateStringProc */ 2579 SetEndOffsetFromAny 2580}; 2581 2582static int 2583TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, int endValue, int* indexPtr) 2584{ 2585 if (Tcl_GetIntFromObj (NULL, objPtr, indexPtr) == TCL_OK) { 2586 return TCL_OK; 2587 } 2588 2589 if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { 2590 /* 2591 * If the object is already an offset from the end of the 2592 * list, or can be converted to one, use it. 2593 */ 2594 2595 *indexPtr = endValue + objPtr->internalRep.longValue; 2596 2597 } else { 2598 /* 2599 * Report a parse error. 2600 */ 2601 2602 if (interp != NULL) { 2603 char *bytes = Tcl_GetString(objPtr); 2604 /* 2605 * The result might not be empty; this resets it which 2606 * should be both a cheap operation, and of little problem 2607 * because this is an error-generation path anyway. 2608 */ 2609 Tcl_ResetResult(interp); 2610 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2611 "bad index \"", bytes, 2612 "\": must be integer or end?-integer?", 2613 (char *) NULL); 2614 if (!strncmp(bytes, "end-", 3)) { 2615 bytes += 3; 2616 } 2617 TclCheckBadOctal(interp, bytes); 2618 } 2619 2620 return TCL_ERROR; 2621 } 2622 2623 return TCL_OK; 2624} 2625 2626/* 2627 *---------------------------------------------------------------------- 2628 * 2629 * UpdateStringOfEndOffset -- 2630 * 2631 * Update the string rep of a Tcl object holding an "end-offset" 2632 * expression. 2633 * 2634 * Results: 2635 * None. 2636 * 2637 * Side effects: 2638 * Stores a valid string in the object's string rep. 2639 * 2640 * This procedure does NOT free any earlier string rep. If it is 2641 * called on an object that already has a valid string rep, it will 2642 * leak memory. 2643 * 2644 *---------------------------------------------------------------------- 2645 */ 2646 2647static void 2648UpdateStringOfEndOffset(objPtr) 2649 register Tcl_Obj* objPtr; 2650{ 2651 char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; 2652 register int len; 2653 2654 strcpy(buffer, "end"); 2655 len = sizeof("end") - 1; 2656 if (objPtr->internalRep.longValue != 0) { 2657 buffer[len++] = '-'; 2658 len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); 2659 } 2660 objPtr->bytes = ckalloc((unsigned) (len+1)); 2661 strcpy(objPtr->bytes, buffer); 2662 objPtr->length = len; 2663} 2664 2665/* 2666 *---------------------------------------------------------------------- 2667 * 2668 * SetEndOffsetFromAny -- 2669 * 2670 * Look for a string of the form "end-offset" and convert it 2671 * to an internal representation holding the offset. 2672 * 2673 * Results: 2674 * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. 2675 * 2676 * Side effects: 2677 * If interp is not NULL, stores an error message in the 2678 * interpreter result. 2679 * 2680 *---------------------------------------------------------------------- 2681 */ 2682 2683static int 2684SetEndOffsetFromAny(interp, objPtr) 2685 Tcl_Interp* interp; /* Tcl interpreter or NULL */ 2686 Tcl_Obj* objPtr; /* Pointer to the object to parse */ 2687{ 2688 int offset; /* Offset in the "end-offset" expression */ 2689 Tcl_ObjType* oldTypePtr = objPtr->typePtr; 2690 /* Old internal rep type of the object */ 2691 register char* bytes; /* String rep of the object */ 2692 int length; /* Length of the object's string rep */ 2693 2694 /* If it's already the right type, we're fine. */ 2695 2696 if (objPtr->typePtr == &EndOffsetType) { 2697 return TCL_OK; 2698 } 2699 2700 /* Check for a string rep of the right form. */ 2701 2702 bytes = Tcl_GetStringFromObj(objPtr, &length); 2703 if ((*bytes != 'e') || (strncmp(bytes, "end", 2704 (size_t)((length > 3) ? 3 : length)) != 0)) { 2705 if (interp != NULL) { 2706 Tcl_ResetResult(interp); 2707 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2708 "bad index \"", bytes, 2709 "\": must be end?-integer?", 2710 (char*) NULL); 2711 } 2712 return TCL_ERROR; 2713 } 2714 2715 /* Convert the string rep */ 2716 2717 if (length <= 3) { 2718 offset = 0; 2719 } else if ((length > 4) && (bytes[3] == '-')) { 2720 /* 2721 * This is our limited string expression evaluator. Pass everything 2722 * after "end-" to Tcl_GetInt, then reverse for offset. 2723 */ 2724 if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { 2725 return TCL_ERROR; 2726 } 2727 offset = -offset; 2728 } else { 2729 /* 2730 * Conversion failed. Report the error. 2731 */ 2732 if (interp != NULL) { 2733 Tcl_ResetResult(interp); 2734 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2735 "bad index \"", bytes, 2736 "\": must be integer or end?-integer?", 2737 (char *) NULL); 2738 } 2739 return TCL_ERROR; 2740 } 2741 2742 /* 2743 * The conversion succeeded. Free the old internal rep and set 2744 * the new one. 2745 */ 2746 2747 if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { 2748 oldTypePtr->freeIntRepProc(objPtr); 2749 } 2750 2751 objPtr->internalRep.longValue = offset; 2752 objPtr->typePtr = &EndOffsetType; 2753 2754 return TCL_OK; 2755} 2756 2757/* 2758 *---------------------------------------------------------------------- 2759 * 2760 * TclCheckBadOctal -- 2761 * 2762 * This procedure checks for a bad octal value and appends a 2763 * meaningful error to the interp's result. 2764 * 2765 * Results: 2766 * 1 if the argument was a bad octal, else 0. 2767 * 2768 * Side effects: 2769 * The interpreter's result is modified. 2770 * 2771 *---------------------------------------------------------------------- 2772 */ 2773 2774int 2775TclCheckBadOctal(interp, value) 2776 Tcl_Interp *interp; /* Interpreter to use for error reporting. 2777 * If NULL, then no error message is left 2778 * after errors. */ 2779 CONST char *value; /* String to check. */ 2780{ 2781 register CONST char *p = value; 2782 2783 /* 2784 * A frequent mistake is invalid octal values due to an unwanted 2785 * leading zero. Try to generate a meaningful error message. 2786 */ 2787 2788 while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2789 p++; 2790 } 2791 if (*p == '+' || *p == '-') { 2792 p++; 2793 } 2794 if (*p == '0') { 2795 while (isdigit(UCHAR(*p))) { /* INTL: digit. */ 2796 p++; 2797 } 2798 while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ 2799 p++; 2800 } 2801 if (*p == '\0') { 2802 /* Reached end of string */ 2803 if (interp != NULL) { 2804 /* 2805 * Don't reset the result here because we want this result 2806 * to be added to an existing error message as extra info. 2807 */ 2808 Tcl_AppendResult(interp, " (looks like invalid octal number)", 2809 (char *) NULL); 2810 } 2811 return 1; 2812 } 2813 } 2814 return 0; 2815} 2816 2817/* 2818 *---------------------------------------------------------------------- 2819 * 2820 * TclFormatInt -- 2821 * 2822 * This procedure formats an integer into a sequence of decimal digit 2823 * characters in a buffer. If the integer is negative, a minus sign is 2824 * inserted at the start of the buffer. A null character is inserted at 2825 * the end of the formatted characters. It is the caller's 2826 * responsibility to ensure that enough storage is available. This 2827 * procedure has the effect of sprintf(buffer, "%d", n) but is faster. 2828 * 2829 * Results: 2830 * An integer representing the number of characters formatted, not 2831 * including the terminating \0. 2832 * 2833 * Side effects: 2834 * The formatted characters are written into the storage pointer to 2835 * by the "buffer" argument. 2836 * 2837 *---------------------------------------------------------------------- 2838 */ 2839 2840int 2841TclFormatInt(buffer, n) 2842 char *buffer; /* Points to the storage into which the 2843 * formatted characters are written. */ 2844 long n; /* The integer to format. */ 2845{ 2846 long intVal; 2847 int i; 2848 int numFormatted, j; 2849 char *digits = "0123456789"; 2850 2851 /* 2852 * Check first whether "n" is zero. 2853 */ 2854 2855 if (n == 0) { 2856 buffer[0] = '0'; 2857 buffer[1] = 0; 2858 return 1; 2859 } 2860 2861 /* 2862 * Check whether "n" is the maximum negative value. This is 2863 * -2^(m-1) for an m-bit word, and has no positive equivalent; 2864 * negating it produces the same value. 2865 */ 2866 2867 if (n == -n) { 2868 sprintf(buffer, "%ld", n); 2869 return strlen(buffer); 2870 } 2871 2872 /* 2873 * Generate the characters of the result backwards in the buffer. 2874 */ 2875 2876 intVal = (n < 0? -n : n); 2877 i = 0; 2878 buffer[0] = '\0'; 2879 do { 2880 i++; 2881 buffer[i] = digits[intVal % 10]; 2882 intVal = intVal/10; 2883 } while (intVal > 0); 2884 if (n < 0) { 2885 i++; 2886 buffer[i] = '-'; 2887 } 2888 numFormatted = i; 2889 2890 /* 2891 * Now reverse the characters. 2892 */ 2893 2894 for (j = 0; j < i; j++, i--) { 2895 char tmp = buffer[i]; 2896 buffer[i] = buffer[j]; 2897 buffer[j] = tmp; 2898 } 2899 return numFormatted; 2900} 2901 2902/* 2903 * Local Variables: 2904 * mode: c 2905 * c-basic-offset: 4 2906 * fill-column: 78 2907 * End: 2908 */ 2909