1/* struct::set - critcl - layer 3 definitions. 2 * 3 * -> Set functions. 4 * Implementations for all set commands. 5 */ 6 7#include "s.h" 8#include "m.h" 9 10/* .................................................. */ 11 12/* 13 *--------------------------------------------------------------------------- 14 * 15 * sm_ADD -- 16 * 17 * Copies the argument tree over into this tree object. Uses direct 18 * access to internal data structures for matching tree objects, and 19 * goes through a serialize/deserialize combination otherwise. 20 * 21 * Results: 22 * A standard Tcl result code. 23 * 24 * Side effects: 25 * Only internal, memory allocation changes ... 26 * 27 *--------------------------------------------------------------------------- 28 */ 29 30int 31sm_ADD (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 32{ 33 /* Syntax: set add SETVAR SET 34 * [0] [1] [2] [3] 35 */ 36 37 SPtr vs, s; 38 Tcl_Obj* val; 39 int new = 0; 40 41 if (objc != 4) { 42 Tcl_WrongNumArgs (interp, 2, objv, "Avar B"); 43 return TCL_ERROR; 44 } 45 46 if (s_get (interp, objv[3], &s) != TCL_OK) { 47 return TCL_ERROR; 48 } 49 50 val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); 51 if (val == NULL) { 52 /* Create missing variable */ 53 54 vs = s_dup (NULL); 55 val = s_new (vs); 56 (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); 57 58 } else if (s_get (interp, val, &vs) != TCL_OK) { 59 return TCL_ERROR; 60 } 61 62 if (s->el.numEntries) { 63 int new, nx = 0; 64 Tcl_HashSearch hs; 65 Tcl_HashEntry* he; 66 CONST char* key; 67 68 for(he = Tcl_FirstHashEntry(&s->el, &hs); 69 he != NULL; 70 he = Tcl_NextHashEntry(&hs)) { 71 key = Tcl_GetHashKey (&s->el, he); 72 if (Tcl_FindHashEntry (&vs->el, key) != NULL) continue; 73 /* Key not known to vs, to be added */ 74 75 /* _Now_ unshare the object, if required */ 76 77 if (Tcl_IsShared (val)) { 78 val = Tcl_DuplicateObj (val); 79 (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); 80 s_get (interp, val, &vs); 81 } 82 83 (void*) Tcl_CreateHashEntry(&vs->el, key, &new); 84 nx = 1; 85 } 86 if (nx) { 87 Tcl_InvalidateStringRep(val); 88 } 89 } 90 return TCL_OK; 91} 92 93/* 94 *--------------------------------------------------------------------------- 95 * 96 * sm_CONTAINS -- 97 * 98 * Copies this tree over into the argument tree. Uses direct access to 99 * internal data structures for matching tree objects, and goes through a 100 * serialize/deserialize combination otherwise. 101 * 102 * Results: 103 * A standard Tcl result code. 104 * 105 * Side effects: 106 * Only internal, memory allocation changes ... 107 * 108 *--------------------------------------------------------------------------- 109 */ 110 111int 112sm_CONTAINS (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 113{ 114 /* Syntax: set contains SET ITEM 115 * [0] [1] [2] [3] 116 */ 117 118 SPtr s; 119 CONST char* item; 120 121 if (objc != 4) { 122 Tcl_WrongNumArgs (interp, 2, objv, "set item"); 123 return TCL_ERROR; 124 } 125 126 if (s_get (interp, objv[2], &s) != TCL_OK) { 127 return TCL_ERROR; 128 } 129 130 item = Tcl_GetString (objv [3]); 131 132 Tcl_SetObjResult (interp, 133 Tcl_NewIntObj (s_contains (s, item))); 134 return TCL_OK; 135} 136 137/* 138 *--------------------------------------------------------------------------- 139 * 140 * sm_DIFFERENCE -- 141 * 142 * Returns a list containing the ancestors of the named node. 143 * 144 * Results: 145 * A standard Tcl result code. 146 * 147 * Side effects: 148 * May release and allocate memory. 149 * 150 *--------------------------------------------------------------------------- 151 */ 152 153int 154sm_DIFFERENCE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 155{ 156 /* Syntax: set difference SETa SETb 157 * [0] [1] [2] [3] 158 */ 159 160 SPtr sa, sb; 161 162 if (objc != 4) { 163 Tcl_WrongNumArgs (interp, 2, objv, "A B"); 164 return TCL_ERROR; 165 } 166 167 if (s_get (interp, objv[2], &sa) != TCL_OK) { 168 return TCL_ERROR; 169 } 170 if (s_get (interp, objv[3], &sb) != TCL_OK) { 171 return TCL_ERROR; 172 } 173 174 Tcl_SetObjResult (interp, 175 s_new (s_difference (sa, sb))); 176 return TCL_OK; 177} 178 179/* 180 *--------------------------------------------------------------------------- 181 * 182 * sm_EMPTY -- 183 * 184 * Appends a value to an attribute of the named node. 185 * May create the attribute. 186 * 187 * Results: 188 * A standard Tcl result code. 189 * 190 * Side effects: 191 * May release and allocate memory. 192 * 193 *--------------------------------------------------------------------------- 194 */ 195 196int 197sm_EMPTY (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 198{ 199 /* Syntax: set empty SET 200 * [0] [1] [2] 201 */ 202 203 SPtr s; 204 205 if (objc != 3) { 206 Tcl_WrongNumArgs (interp, 2, objv, "set"); 207 return TCL_ERROR; 208 } 209 210 if (objv[2]->typePtr == s_ltype ()) { 211 int lc; 212 Tcl_Obj** lv; 213 Tcl_ListObjGetElements(interp, objv[2], &lc, &lv); 214 Tcl_SetObjResult (interp, Tcl_NewIntObj (lc == 0)); 215 return TCL_OK; 216 } 217 218 if (s_get (interp, objv[2], &s) != TCL_OK) { 219 return TCL_ERROR; 220 } 221 222 Tcl_SetObjResult (interp, 223 Tcl_NewIntObj (s_empty (s))); 224 return TCL_OK; 225} 226 227/* 228 *--------------------------------------------------------------------------- 229 * 230 * sm_EQUAL -- 231 * 232 * Returns a dictionary mapping from nodes to attribute values, for a 233 * named attribute. 234 * 235 * Results: 236 * A standard Tcl result code. 237 * 238 * Side effects: 239 * May release and allocate memory. 240 * 241 *--------------------------------------------------------------------------- 242 */ 243 244int 245sm_EQUAL (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 246{ 247 /* Syntax: set equal SETa SETb 248 * [0] [1] [2] [3] 249 */ 250 251 SPtr sa, sb; 252 253 if (objc != 4) { 254 Tcl_WrongNumArgs (interp, 2, objv, "A B"); 255 return TCL_ERROR; 256 } 257 258 if (s_get (interp, objv[2], &sa) != TCL_OK) { 259 return TCL_ERROR; 260 } 261 if (s_get (interp, objv[3], &sb) != TCL_OK) { 262 return TCL_ERROR; 263 } 264 265 Tcl_SetObjResult (interp, 266 Tcl_NewIntObj (s_equal (sa, sb))); 267 return TCL_OK; 268} 269 270/* 271 *--------------------------------------------------------------------------- 272 * 273 * sm_EXCLUDE -- 274 * 275 * Returns a list of all direct or indirect descendants of the named 276 * node, possibly run through a Tcl command prefix for filtering. 277 * 278 * Results: 279 * A standard Tcl result code. 280 * 281 * Side effects: 282 * May release and allocate memory. Per the filter command prefix, if 283 * one has been specified. 284 * 285 *--------------------------------------------------------------------------- 286 */ 287 288int 289sm_EXCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 290{ 291 /* Syntax: set exclude SETVAR ITEM 292 * [0] [1] [2] [3] 293 */ 294 295 SPtr vs; 296 Tcl_Obj* val; 297 char* key; 298 299 if (objc != 4) { 300 Tcl_WrongNumArgs (interp, 2, objv, "Avar element"); 301 return TCL_ERROR; 302 } 303 304 val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); 305 if (val == NULL) { 306 return TCL_ERROR; 307 } 308 if (s_get (interp, val, &vs) != TCL_OK) { 309 return TCL_ERROR; 310 } 311 312 key = Tcl_GetString (objv[3]); 313 if (s_contains (vs, key)) { 314 if (Tcl_IsShared (val)) { 315 val = Tcl_DuplicateObj (val); 316 (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); 317 s_get (interp, val, &vs); 318 } 319 320 s_subtract1 (vs, key); 321 Tcl_InvalidateStringRep(val); 322 } 323 return TCL_OK; 324} 325 326/* 327 *--------------------------------------------------------------------------- 328 * 329 * sm_INCLUDE -- 330 * 331 * Deletes the named nodes, but not its children. They are put into the 332 * place where the deleted node was. Complementary to sm_SPLICE. 333 * 334 * Results: 335 * A standard Tcl result code. 336 * 337 * Side effects: 338 * May release and allocate memory. 339 * 340 *--------------------------------------------------------------------------- 341 */ 342 343int 344sm_INCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 345{ 346 /* Syntax: set include SETVAR ITEM 347 * [0] [1] [2] [3] 348 */ 349 350 SPtr vs; 351 Tcl_Obj* val; 352 353 if (objc != 4) { 354 Tcl_WrongNumArgs (interp, 2, objv, "Avar element"); 355 return TCL_ERROR; 356 } 357 358 val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0); 359 if (val == NULL) { 360 /* Create missing variable */ 361 362 vs = s_dup (NULL); 363 s_add1 (vs, Tcl_GetString (objv[3])); 364 val = s_new (vs); 365 366 (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); 367 } else { 368 /* Extend variable */ 369 char* key; 370 371 if (s_get (interp, val, &vs) != TCL_OK) { 372 return TCL_ERROR; 373 } 374 375 key = Tcl_GetString (objv[3]); 376 if (!s_contains (vs, key)) { 377 if (Tcl_IsShared (val)) { 378 val = Tcl_DuplicateObj (val); 379 (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); 380 s_get (interp, val, &vs); 381 } 382 383 s_add1 (vs, key); 384 Tcl_InvalidateStringRep(val); 385 } 386 } 387 return TCL_OK; 388} 389 390/* 391 *--------------------------------------------------------------------------- 392 * 393 * sm_INTERSECT -- 394 * 395 * Deletes the named node and its children. 396 * 397 * Results: 398 * A standard Tcl result code. 399 * 400 * Side effects: 401 * May release and allocate memory. 402 * 403 *--------------------------------------------------------------------------- 404 */ 405 406int 407sm_INTERSECT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 408{ 409 /* Syntax: set intersect ?SET...? 410 * [0] [1] [2] 411 */ 412 413 SPtr sa, sb, next, acc; 414 int i; 415 416 if (objc == 2) { 417 /* intersect nothing = nothing */ 418 Tcl_SetObjResult (interp, s_new (s_dup (NULL))); 419 return TCL_OK; 420 } 421 422 for (i = 2; i < objc; i++) { 423 if (s_get (interp, objv[i], &sa) != TCL_OK) { 424 return TCL_ERROR; 425 } 426 } 427 428 s_get (interp, objv[2], &sa); 429 430 if (objc == 3) { 431 /* intersect with itself = unchanged */ 432 Tcl_SetObjResult (interp, s_new (s_dup (sa))); 433 return TCL_OK; 434 } 435 436 acc = sa; 437 for (i = 3; i < objc; i++) { 438 s_get (interp, objv[i], &sb); 439 next = s_intersect (acc, sb); 440 if (acc != sa) s_free (acc); 441 acc = next; 442 if (s_empty (acc)) break; 443 } 444 445 if (acc == sa) { 446 acc = s_dup (acc); 447 } 448 449 Tcl_SetObjResult (interp, s_new (acc)); 450 return TCL_OK; 451} 452 453/* 454 *--------------------------------------------------------------------------- 455 * 456 * sm_INTERSECT3 -- 457 * 458 * Returns a non-negative integer number describing the distance between 459 * the named node and the root of the tree. A depth of 0 implies that 460 * the node is the root node. 461 * 462 * Results: 463 * A standard Tcl result code. 464 * 465 * Side effects: 466 * May release and allocate memory. 467 * 468 *--------------------------------------------------------------------------- 469 */ 470 471int 472sm_INTERSECT3 (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 473{ 474 /* Syntax: set intersect3 SETa SETb 475 * [0] [1] [2] [3] 476 */ 477 478 SPtr sa, sb; 479 Tcl_Obj* lv [3]; 480 481 if (objc != 4) { 482 Tcl_WrongNumArgs (interp, 2, objv, "A B"); 483 return TCL_ERROR; 484 } 485 486 if (s_get (interp, objv[2], &sa) != TCL_OK) { 487 return TCL_ERROR; 488 } 489 if (s_get (interp, objv[3], &sb) != TCL_OK) { 490 return TCL_ERROR; 491 } 492 493 lv [0] = s_new (s_intersect (sa, sb)); 494 lv [1] = s_new (s_difference (sa, sb)); 495 lv [2] = s_new (s_difference (sb, sa)); 496 497 Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv)); 498 return TCL_OK; 499} 500 501/* 502 *--------------------------------------------------------------------------- 503 * 504 * sm_SIZE -- 505 * 506 * Returns a list of all descendants of the named node, possibly run 507 * through a Tcl command prefix for filtering. 508 * 509 * Results: 510 * A standard Tcl result code. 511 * 512 * Side effects: 513 * May release and allocate memory. Per the filter command prefix, if 514 * one has been specified. 515 * 516 *--------------------------------------------------------------------------- 517 */ 518 519int 520sm_SIZE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 521{ 522 /* Syntax: set size SET 523 * [0] [1] [2] 524 */ 525 526 SPtr s; 527 528 if (objc != 3) { 529 Tcl_WrongNumArgs (interp, 2, objv, "set"); 530 return TCL_ERROR; 531 } 532 533 if (s_get (interp, objv[2], &s) != TCL_OK) { 534 return TCL_ERROR; 535 } 536 537 Tcl_SetObjResult (interp, 538 Tcl_NewIntObj (s_size (s))); 539 return TCL_OK; 540} 541 542/* 543 *--------------------------------------------------------------------------- 544 * 545 * sm_SUBSETOF -- 546 * 547 * Parses a Tcl value containing a serialized tree and copies it over 548 * he existing tree. 549 * 550 * Results: 551 * A standard Tcl result code. 552 * 553 * Side effects: 554 * May release and allocate memory. 555 * 556 *--------------------------------------------------------------------------- 557 */ 558 559int 560sm_SUBSETOF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 561{ 562 /* Syntax: set subsetof SETa SETb 563 * [0] [1] [2] [3] 564 */ 565 566 SPtr sa, sb; 567 568 if (objc != 4) { 569 Tcl_WrongNumArgs (interp, 2, objv, "A B"); 570 return TCL_ERROR; 571 } 572 573 if (s_get (interp, objv[2], &sa) != TCL_OK) { 574 return TCL_ERROR; 575 } 576 if (s_get (interp, objv[3], &sb) != TCL_OK) { 577 return TCL_ERROR; 578 } 579 580 Tcl_SetObjResult (interp, 581 Tcl_NewIntObj (s_subsetof (sa, sb))); 582 return TCL_OK; 583} 584 585/* 586 *--------------------------------------------------------------------------- 587 * 588 * sm_SUBTRACT -- 589 * 590 * Destroys the whole tree object. 591 * 592 * Results: 593 * A standard Tcl result code. 594 * 595 * Side effects: 596 * Releases memory. 597 * 598 *--------------------------------------------------------------------------- 599 */ 600 601int 602sm_SUBTRACT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 603{ 604 /* Syntax: set subtract SETVAR SET 605 * [0] [1] [2] [3] 606 */ 607 608 SPtr vs, s; 609 Tcl_Obj* val; 610 int del; 611 612 if (objc != 4) { 613 Tcl_WrongNumArgs (interp, 2, objv, "Avar B"); 614 return TCL_ERROR; 615 } 616 617 val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG); 618 if (val == NULL) { 619 return TCL_ERROR; 620 } 621 if (s_get (interp, val, &vs) != TCL_OK) { 622 return TCL_ERROR; 623 } 624 if (s_get (interp, objv[3], &s) != TCL_OK) { 625 return TCL_ERROR; 626 } 627 628 if (s->el.numEntries) { 629 int new, dx = 0; 630 Tcl_HashSearch hs; 631 Tcl_HashEntry* he; 632 CONST char* key; 633 634 for(he = Tcl_FirstHashEntry(&s->el, &hs); 635 he != NULL; 636 he = Tcl_NextHashEntry(&hs)) { 637 key = Tcl_GetHashKey (&s->el, he); 638 if (Tcl_FindHashEntry (&vs->el, key) == NULL) continue; 639 /* Key known to vs, to be removed */ 640 641 /* _Now_ unshare the object, if required */ 642 643 if (Tcl_IsShared (val)) { 644 val = Tcl_DuplicateObj (val); 645 (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0); 646 s_get (interp, val, &vs); 647 } 648 649 Tcl_DeleteHashEntry (Tcl_FindHashEntry (&vs->el, key)); 650 dx = 1; 651 } 652 if (dx) { 653 Tcl_InvalidateStringRep(val); 654 } 655 } 656 return TCL_OK; 657} 658 659/* 660 *--------------------------------------------------------------------------- 661 * 662 * sm_SYMDIFF -- 663 * 664 * Returns a boolean value signaling whether the named node exists in 665 * the tree. True implies existence, and false non-existence. 666 * 667 * Results: 668 * A standard Tcl result code. 669 * 670 * Side effects: 671 * May release and allocate memory. 672 * 673 *--------------------------------------------------------------------------- 674 */ 675 676int 677sm_SYMDIFF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 678{ 679 /* Syntax: set symdiff SETa SETb 680 * [0] [1] [2] [3] 681 */ 682 683 SPtr sa, sb, xa, xb, u; 684 685 if (objc != 4) { 686 Tcl_WrongNumArgs (interp, 2, objv, "A B"); 687 return TCL_ERROR; 688 } 689 690 if (s_get (interp, objv[2], &sa) != TCL_OK) { 691 return TCL_ERROR; 692 } 693 if (s_get (interp, objv[3], &sb) != TCL_OK) { 694 return TCL_ERROR; 695 } 696 697 if (s_get (interp, objv[2], &sa) != TCL_OK) { 698 return TCL_ERROR; 699 } 700 if (s_get (interp, objv[3], &sb) != TCL_OK) { 701 return TCL_ERROR; 702 } 703 704 xa = s_difference (sa, sb); 705 xb = s_difference (sb, sa); 706 u = s_union (xa, xb); 707 708 s_free (xa); 709 s_free (xb); 710 711 Tcl_SetObjResult (interp, s_new (u)); 712 return TCL_OK; 713} 714 715/* 716 *--------------------------------------------------------------------------- 717 * 718 * sm_UNION -- 719 * 720 * Returns the value of the named attribute at the given node. 721 * 722 * Results: 723 * A standard Tcl result code. 724 * 725 * Side effects: 726 * May release and allocate memory. 727 * 728 *--------------------------------------------------------------------------- 729 */ 730 731int 732sm_UNION (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv) 733{ 734 /* Syntax: set union ?SET...? 735 * [0] [1] [2] 736 */ 737 738 SPtr sa, acc; 739 int i; 740 741 if (objc == 2) { 742 /* union nothing = nothing */ 743 Tcl_SetObjResult (interp, s_new (s_dup (NULL))); 744 return TCL_OK; 745 } 746 747 for (i = 2; i < objc; i++) { 748 if (s_get (interp, objv[i], &sa) != TCL_OK) { 749 return TCL_ERROR; 750 } 751 } 752 753 acc = s_dup (NULL); 754 755 for (i = 2; i < objc; i++) { 756 s_get (interp, objv[i], &sa); 757 s_add (acc, sa, NULL); 758 } 759 760 Tcl_SetObjResult (interp, s_new (acc)); 761 return TCL_OK; 762} 763 764/* .................................................. */ 765 766/* 767 * Local Variables: 768 * mode: c 769 * c-basic-offset: 4 770 * fill-column: 78 771 * End: 772 */ 773