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